diff --git a/lib/common/Pulse.Lib.Core.Refs.fsti b/lib/common/Pulse.Lib.Core.Refs.fsti new file mode 100644 index 000000000..f61a5f232 --- /dev/null +++ b/lib/common/Pulse.Lib.Core.Refs.fsti @@ -0,0 +1,226 @@ +(* + 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.Refs +open FStar.Ghost +open PulseCore.FractionalPermission +open PulseCore.Observability +open FStar.PCM +module T = FStar.Tactics.V2 +open Pulse.Lib.Dv {} +open FStar.ExtractAs +open Pulse.Lib.Core + +// These are PCM references in Type u#3 and should not be used directly. +// The modules Pulse.Lib.(Ghost)PCMReference provide universe-polymorphic wrappers. + +//////////////////////////////////////////////////////// +//Core PCM references +//////////////////////////////////////////////////////// +val core_pcm_ref : Type0 +val null_core_pcm_ref : core_pcm_ref +val is_null_core_pcm_ref (p:core_pcm_ref) + : b:bool { b <==> p == null_core_pcm_ref } + +let pcm_ref + (#a:Type u#3) + (p:FStar.PCM.pcm a) +: Type0 += core_pcm_ref + +val pcm_pts_to + #a + (#p:pcm a) + ([@@@mkey] r:pcm_ref p) + (v:a) +: slprop + +val timeless_pcm_pts_to + #a + (#p:pcm a) + (r:pcm_ref p) + (v:a) +: Lemma (timeless (pcm_pts_to r v)) + [SMTPat (timeless (pcm_pts_to r v))] + +let pcm_ref_null + (#a:Type) + (p:FStar.PCM.pcm a) +: pcm_ref p += null_core_pcm_ref + +let is_pcm_ref_null + (#a:Type) + (#p:FStar.PCM.pcm a) + (r:pcm_ref p) +: b:bool { b <==> r == pcm_ref_null p } += is_null_core_pcm_ref r + +val pts_to_not_null + (#a:Type) + (#p:FStar.PCM.pcm a) + (r:pcm_ref p) + (v:a) +: stt_ghost (squash (not (is_pcm_ref_null r))) + emp_inames + (pcm_pts_to r v) + (fun _ -> pcm_pts_to r v) + +val alloc + #a + (#pcm:pcm a) + (x:a{pcm.refine x}) +: stt (pcm_ref pcm) + emp + (fun r -> pcm_pts_to r x) + +val read + (#a:Type) + (#p:pcm a) + (r:pcm_ref p) + (x:erased a) + (f:(v:a{compatible p x v} + -> GTot (y:a{compatible p y v /\ + FStar.PCM.frame_compatible p x v y}))) +: stt (v:a{compatible p x v /\ p.refine v}) + (pcm_pts_to r x) + (fun v -> pcm_pts_to r (f v)) + +val write + (#a:Type) + (#p:pcm a) + (r:pcm_ref p) + (x y:Ghost.erased a) + (f:FStar.PCM.frame_preserving_upd p x y) +: stt unit + (pcm_pts_to r x) + (fun _ -> pcm_pts_to r y) + +val share + (#a:Type) + (#pcm:pcm a) + (r:pcm_ref pcm) + (v0:FStar.Ghost.erased a) + (v1:FStar.Ghost.erased a{composable pcm v0 v1}) +: stt_ghost unit + emp_inames + (pcm_pts_to r (v0 `op pcm` v1)) + (fun _ -> pcm_pts_to r v0 ** pcm_pts_to r v1) + +[@@allow_ambiguous] +val gather + (#a:Type) + (#pcm:pcm a) + (r:pcm_ref pcm) + (v0:FStar.Ghost.erased a) + (v1:FStar.Ghost.erased a) +: stt_ghost (squash (composable pcm v0 v1)) + emp_inames + (pcm_pts_to r v0 ** pcm_pts_to r v1) + (fun _ -> pcm_pts_to r (op pcm v0 v1)) + +///////////////////////////////////////////////////////////////////////// +[@@erasable] +val core_ghost_pcm_ref : Type0 + +val null_core_ghost_pcm_ref : core_ghost_pcm_ref + +let ghost_pcm_ref + (#a:Type u#3) + (p:FStar.PCM.pcm a) +: Type0 += core_ghost_pcm_ref + +val ghost_pcm_pts_to + #a + (#p:pcm a) + ([@@@mkey] r:ghost_pcm_ref p) + (v:a) +: slprop + +val timeless_ghost_pcm_pts_to + #a + (#p:pcm a) + (r:ghost_pcm_ref p) + (v:a) +: Lemma (timeless (ghost_pcm_pts_to r v)) + [SMTPat (timeless (ghost_pcm_pts_to r v))] + +val ghost_pts_to_not_null + (#a:Type) + (#p:pcm a) + (r:ghost_pcm_ref p) + (v:a) +: stt_ghost (squash (r =!= null_core_ghost_pcm_ref)) + emp_inames + (ghost_pcm_pts_to r v) + (fun _ -> ghost_pcm_pts_to r v) + +val ghost_alloc + #a + (#pcm:pcm a) + (x:erased a{pcm.refine x}) +: stt_ghost (ghost_pcm_ref pcm) + emp_inames + emp + (fun r -> ghost_pcm_pts_to r x) + +val ghost_read + (#a:Type) + (#p:pcm a) + (r:ghost_pcm_ref p) + (x:erased a) + (f:(v:a{compatible p x v} + -> GTot (y:a{compatible p y v /\ + FStar.PCM.frame_compatible p x v y}))) +: stt_ghost (erased (v:a{compatible p x v /\ p.refine v})) + emp_inames + (ghost_pcm_pts_to r x) + (fun v -> ghost_pcm_pts_to r (f v)) + +val ghost_write + (#a:Type) + (#p:pcm a) + (r:ghost_pcm_ref p) + (x y:Ghost.erased a) + (f:FStar.PCM.frame_preserving_upd p x y) +: stt_ghost unit + emp_inames + (ghost_pcm_pts_to r x) + (fun _ -> ghost_pcm_pts_to r y) + +val ghost_share + (#a:Type) + (#pcm:pcm a) + (r:ghost_pcm_ref pcm) + (v0:FStar.Ghost.erased a) + (v1:FStar.Ghost.erased a{composable pcm v0 v1}) +: stt_ghost unit + emp_inames + (ghost_pcm_pts_to r (v0 `op pcm` v1)) + (fun _ -> ghost_pcm_pts_to r v0 ** ghost_pcm_pts_to r v1) + +[@@allow_ambiguous] +val ghost_gather + (#a:Type) + (#pcm:pcm a) + (r:ghost_pcm_ref pcm) + (v0:FStar.Ghost.erased a) + (v1:FStar.Ghost.erased a) +: stt_ghost (squash (composable pcm v0 v1)) + emp_inames + (ghost_pcm_pts_to r v0 ** ghost_pcm_pts_to r v1) + (fun _ -> ghost_pcm_pts_to r (op pcm v0 v1)) diff --git a/lib/common/Pulse.Lib.Core.fsti b/lib/common/Pulse.Lib.Core.fsti index d6f2668ef..37bb8b146 100644 --- a/lib/common/Pulse.Lib.Core.fsti +++ b/lib/common/Pulse.Lib.Core.fsti @@ -658,362 +658,6 @@ val unreachable (#a:Type) (#p:slprop) (#q:a -> slprop) (_:squash False) val elim_false (a:Type) (p:a -> slprop) : stt_ghost a emp_inames (pure False) p -//////////////////////////////////////////////////////// -//Core PCM references -//////////////////////////////////////////////////////// -val core_pcm_ref : Type0 -val null_core_pcm_ref : core_pcm_ref -val is_null_core_pcm_ref (p:core_pcm_ref) - : b:bool { b <==> p == null_core_pcm_ref } - -let pcm_ref - (#a:Type u#a) - (p:FStar.PCM.pcm a) -: Type0 -= core_pcm_ref - -val pcm_pts_to - (#a:Type u#1) - (#p:pcm a) - ([@@@mkey] r:pcm_ref p) - (v:a) -: slprop - -val timeless_pcm_pts_to - (#a:Type u#1) - (#p:pcm a) - (r:pcm_ref p) - (v:a) -: Lemma (timeless (pcm_pts_to r v)) - [SMTPat (timeless (pcm_pts_to r v))] - -let pcm_ref_null - (#a:Type) - (p:FStar.PCM.pcm a) -: pcm_ref p -= null_core_pcm_ref - -let is_pcm_ref_null - (#a:Type) - (#p:FStar.PCM.pcm a) - (r:pcm_ref p) -: b:bool { b <==> r == pcm_ref_null p } -= is_null_core_pcm_ref r - -val pts_to_not_null - (#a:Type) - (#p:FStar.PCM.pcm a) - (r:pcm_ref p) - (v:a) -: stt_ghost (squash (not (is_pcm_ref_null r))) - emp_inames - (pcm_pts_to r v) - (fun _ -> pcm_pts_to r v) - -val alloc - (#a:Type u#1) - (#pcm:pcm a) - (x:a{pcm.refine x}) -: stt (pcm_ref pcm) - emp - (fun r -> pcm_pts_to r x) - -val read - (#a:Type) - (#p:pcm a) - (r:pcm_ref p) - (x:erased a) - (f:(v:a{compatible p x v} - -> GTot (y:a{compatible p y v /\ - FStar.PCM.frame_compatible p x v y}))) -: stt (v:a{compatible p x v /\ p.refine v}) - (pcm_pts_to r x) - (fun v -> pcm_pts_to r (f v)) - -val write - (#a:Type) - (#p:pcm a) - (r:pcm_ref p) - (x y:Ghost.erased a) - (f:FStar.PCM.frame_preserving_upd p x y) -: stt unit - (pcm_pts_to r x) - (fun _ -> pcm_pts_to r y) - -val share - (#a:Type) - (#pcm:pcm a) - (r:pcm_ref pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a{composable pcm v0 v1}) -: stt_ghost unit - emp_inames - (pcm_pts_to r (v0 `op pcm` v1)) - (fun _ -> pcm_pts_to r v0 ** pcm_pts_to r v1) - -[@@allow_ambiguous] -val gather - (#a:Type) - (#pcm:pcm a) - (r:pcm_ref pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a) -: stt_ghost (squash (composable pcm v0 v1)) - emp_inames - (pcm_pts_to r v0 ** pcm_pts_to r v1) - (fun _ -> pcm_pts_to r (op pcm v0 v1)) - -///////////////////////////////////////////////////////////////////////// -[@@erasable] -val core_ghost_pcm_ref : Type0 - -val null_core_ghost_pcm_ref : core_ghost_pcm_ref - -let ghost_pcm_ref - (#a:Type u#a) - (p:FStar.PCM.pcm a) -: Type0 -= core_ghost_pcm_ref - -instance val non_informative_ghost_pcm_ref - (a:Type u#a) (p:FStar.PCM.pcm a) - : NonInformative.non_informative (ghost_pcm_ref p) - -val ghost_pcm_pts_to - (#a:Type u#1) - (#p:pcm a) - ([@@@mkey] r:ghost_pcm_ref p) - (v:a) -: slprop - -val timeless_ghost_pcm_pts_to - (#a:Type u#1) - (#p:pcm a) - (r:ghost_pcm_ref p) - (v:a) -: Lemma (timeless (ghost_pcm_pts_to r v)) - [SMTPat (timeless (ghost_pcm_pts_to r v))] - -val ghost_pts_to_not_null - (#a:Type) - (#p:pcm a) - (r:ghost_pcm_ref p) - (v:a) -: stt_ghost (squash (r =!= null_core_ghost_pcm_ref)) - emp_inames - (ghost_pcm_pts_to r v) - (fun _ -> ghost_pcm_pts_to r v) - -val ghost_alloc - (#a:Type u#1) - (#pcm:pcm a) - (x:erased a{pcm.refine x}) -: stt_ghost (ghost_pcm_ref pcm) - emp_inames - emp - (fun r -> ghost_pcm_pts_to r x) - -val ghost_read - (#a:Type) - (#p:pcm a) - (r:ghost_pcm_ref p) - (x:erased a) - (f:(v:a{compatible p x v} - -> GTot (y:a{compatible p y v /\ - FStar.PCM.frame_compatible p x v y}))) -: stt_ghost (erased (v:a{compatible p x v /\ p.refine v})) - emp_inames - (ghost_pcm_pts_to r x) - (fun v -> ghost_pcm_pts_to r (f v)) - -val ghost_write - (#a:Type) - (#p:pcm a) - (r:ghost_pcm_ref p) - (x y:Ghost.erased a) - (f:FStar.PCM.frame_preserving_upd p x y) -: stt_ghost unit - emp_inames - (ghost_pcm_pts_to r x) - (fun _ -> ghost_pcm_pts_to r y) - -val ghost_share - (#a:Type) - (#pcm:pcm a) - (r:ghost_pcm_ref pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a{composable pcm v0 v1}) -: stt_ghost unit - emp_inames - (ghost_pcm_pts_to r (v0 `op pcm` v1)) - (fun _ -> ghost_pcm_pts_to r v0 ** ghost_pcm_pts_to r v1) - -[@@allow_ambiguous] -val ghost_gather - (#a:Type) - (#pcm:pcm a) - (r:ghost_pcm_ref pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a) -: stt_ghost (squash (composable pcm v0 v1)) - emp_inames - (ghost_pcm_pts_to r v0 ** ghost_pcm_pts_to r v1) - (fun _ -> ghost_pcm_pts_to r (op pcm v0 v1)) - -//////////////////////////////////////////////////////// -//Big PCM references -//////////////////////////////////////////////////////// -val big_pcm_pts_to - (#a:Type u#2) - (#p:pcm a) - ([@@@mkey] r:pcm_ref p) - (v:a) -: slprop - - -val timeless_big_pcm_pts_to - (#a:Type u#2) - (#p:pcm a) - (r:pcm_ref p) - (v:a) -: Lemma (timeless (big_pcm_pts_to r v)) - [SMTPat (timeless (big_pcm_pts_to r v))] - -val big_pts_to_not_null - (#a:Type) - (#p:FStar.PCM.pcm a) - (r:pcm_ref p) - (v:a) -: stt_ghost (squash (not (is_pcm_ref_null r))) - emp_inames - (big_pcm_pts_to r v) - (fun _ -> big_pcm_pts_to r v) - -val big_alloc - (#a:Type u#2) - (#pcm:pcm a) - (x:a{pcm.refine x}) -: stt (pcm_ref pcm) - emp - (fun r -> big_pcm_pts_to r x) - -val big_read - (#a:Type) - (#p:pcm a) - (r:pcm_ref p) - (x:erased a) - (f:(v:a{compatible p x v} - -> GTot (y:a{compatible p y v /\ - FStar.PCM.frame_compatible p x v y}))) -: stt (v:a{compatible p x v /\ p.refine v}) - (big_pcm_pts_to r x) - (fun v -> big_pcm_pts_to r (f v)) - -val big_write - (#a:Type) - (#p:pcm a) - (r:pcm_ref p) - (x y:Ghost.erased a) - (f:FStar.PCM.frame_preserving_upd p x y) -: stt unit - (big_pcm_pts_to r x) - (fun _ -> big_pcm_pts_to r y) - -val big_share - (#a:Type) - (#pcm:pcm a) - (r:pcm_ref pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a{composable pcm v0 v1}) -: stt_ghost unit - emp_inames - (big_pcm_pts_to r (v0 `op pcm` v1)) - (fun _ -> big_pcm_pts_to r v0 ** big_pcm_pts_to r v1) - -[@@allow_ambiguous] -val big_gather - (#a:Type) - (#pcm:pcm a) - (r:pcm_ref pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a) -: stt_ghost (squash (composable pcm v0 v1)) - emp_inames - (big_pcm_pts_to r v0 ** big_pcm_pts_to r v1) - (fun _ -> big_pcm_pts_to r (op pcm v0 v1)) - -val big_ghost_pcm_pts_to - (#a:Type u#2) - (#p:pcm a) - ([@@@mkey] r:ghost_pcm_ref p) - (v:a) -: slprop - -val timeless_big_ghost_pcm_pts_to - (#a:Type u#2) - (#p:pcm a) - (r:ghost_pcm_ref p) - (v:a) -: Lemma (timeless (big_ghost_pcm_pts_to r v)) - [SMTPat (timeless (big_ghost_pcm_pts_to r v))] - -val big_ghost_alloc - (#a:Type) - (#pcm:pcm a) - (x:erased a{pcm.refine x}) -: stt_ghost (ghost_pcm_ref pcm) - emp_inames - emp - (fun r -> big_ghost_pcm_pts_to r x) - -val big_ghost_read - (#a:Type) - (#p:pcm a) - (r:ghost_pcm_ref p) - (x:erased a) - (f:(v:a{compatible p x v} - -> GTot (y:a{compatible p y v /\ - FStar.PCM.frame_compatible p x v y}))) -: stt_ghost (erased (v:a{compatible p x v /\ p.refine v})) - emp_inames - (big_ghost_pcm_pts_to r x) - (fun v -> big_ghost_pcm_pts_to r (f v)) - -val big_ghost_write - (#a:Type) - (#p:pcm a) - (r:ghost_pcm_ref p) - (x y:Ghost.erased a) - (f:FStar.PCM.frame_preserving_upd p x y) -: stt_ghost unit - emp_inames - (big_ghost_pcm_pts_to r x) - (fun _ -> big_ghost_pcm_pts_to r y) - -val big_ghost_share - (#a:Type) - (#pcm:pcm a) - (r:ghost_pcm_ref pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a{composable pcm v0 v1}) -: stt_ghost unit - emp_inames - (big_ghost_pcm_pts_to r (v0 `op pcm` v1)) - (fun _ -> big_ghost_pcm_pts_to r v0 ** big_ghost_pcm_pts_to r v1) - -[@@allow_ambiguous] -val big_ghost_gather - (#a:Type) - (#pcm:pcm a) - (r:ghost_pcm_ref pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a) -: stt_ghost (squash (composable pcm v0 v1)) - emp_inames - (big_ghost_pcm_pts_to r v0 ** big_ghost_pcm_pts_to r v1) - (fun _ -> big_ghost_pcm_pts_to r (op pcm v0 v1)) - - // 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"] diff --git a/lib/core/Pulse.Lib.Core.Refs.fst b/lib/core/Pulse.Lib.Core.Refs.fst new file mode 100644 index 000000000..1051b6ac6 --- /dev/null +++ b/lib/core/Pulse.Lib.Core.Refs.fst @@ -0,0 +1,90 @@ +(* + 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.Refs +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 +module Sep = PulseCore.IndirectionTheorySep +open Pulse.Lib.Core +friend Pulse.Lib.Core + +////////////////////////////////////////////////////////////////////////// +// References +////////////////////////////////////////////////////////////////////////// +let core_pcm_ref = PulseCore.Action.core_ref +let null_core_pcm_ref = PulseCore.Action.core_ref_null +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 pts_to_not_null #a #p r v = A.pts_to_not_null #a #p r v + +let alloc + (#a:Type) + (#pcm:pcm a) + (x:a{pcm.refine x}) +: stt (pcm_ref pcm) + emp + (fun r -> pcm_pts_to r x) += A.lift_atomic (A.alloc #a #pcm x) + +let read + (#a:Type) + (#p:pcm a) + (r:pcm_ref p) + (x:erased a) + (f:(v:a{compatible p x v} + -> GTot (y:a{compatible p y v /\ + FStar.PCM.frame_compatible p x v y}))) +: stt (v:a{compatible p x v /\ p.refine v}) + (pcm_pts_to r x) + (fun v -> pcm_pts_to r (f v)) += A.lift_atomic (A.read r x f) + +let write + (#a:Type) + (#p:pcm a) + (r:pcm_ref p) + (x y:Ghost.erased a) + (f:FStar.PCM.frame_preserving_upd p x y) +: stt unit + (pcm_pts_to r x) + (fun _ -> pcm_pts_to r y) += A.lift_atomic (A.write r x y f) + +let share = A.share +let gather = A.gather + +//////////////////////////////////////////////////////// +// ghost refs +//////////////////////////////////////////////////////// +let core_ghost_pcm_ref = PulseCore.Action.core_ghost_ref + +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 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 +let ghost_write = A.ghost_write +let ghost_share = A.ghost_share +let ghost_gather = A.ghost_gather diff --git a/lib/core/Pulse.Lib.Core.fst b/lib/core/Pulse.Lib.Core.fst index ce1051008..68b461d16 100644 --- a/lib/core/Pulse.Lib.Core.fst +++ b/lib/core/Pulse.Lib.Core.fst @@ -306,153 +306,6 @@ let elim_false (a:Type) (p:a -> slprop) = (A.noop (pure False)) (fun _ -> A.bind_ghost (A.elim_pure False) unreachable ) -////////////////////////////////////////////////////////////////////////// -// References -////////////////////////////////////////////////////////////////////////// -let core_pcm_ref = PulseCore.Action.core_ref -let null_core_pcm_ref = PulseCore.Action.core_ref_null -let is_null_core_pcm_ref r = PulseCore.Action.is_core_ref_null r - -let pcm_pts_to (#a:Type u#1) (#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 pts_to_not_null #a #p r v = A.pts_to_not_null #a #p r v - -let alloc - (#a:Type u#1) - (#pcm:pcm a) - (x:a{pcm.refine x}) -: stt (pcm_ref pcm) - emp - (fun r -> pcm_pts_to r x) -= A.lift_atomic (A.alloc #a #pcm x) - -let read - (#a:Type) - (#p:pcm a) - (r:pcm_ref p) - (x:erased a) - (f:(v:a{compatible p x v} - -> GTot (y:a{compatible p y v /\ - FStar.PCM.frame_compatible p x v y}))) -: stt (v:a{compatible p x v /\ p.refine v}) - (pcm_pts_to r x) - (fun v -> pcm_pts_to r (f v)) -= A.lift_atomic (A.read r x f) - -let write - (#a:Type) - (#p:pcm a) - (r:pcm_ref p) - (x y:Ghost.erased a) - (f:FStar.PCM.frame_preserving_upd p x y) -: stt unit - (pcm_pts_to r x) - (fun _ -> pcm_pts_to r y) -= A.lift_atomic (A.write r x y f) - -let share = A.share -let gather = A.gather - -//////////////////////////////////////////////////////// -// ghost refs -//////////////////////////////////////////////////////// -let core_ghost_pcm_ref = PulseCore.Action.core_ghost_ref - -let null_core_ghost_pcm_ref = PulseCore.Action.core_ghost_ref_null - -instance non_informative_ghost_pcm_ref a p = { - reveal = (fun r -> Ghost.reveal r) <: NonInformative.revealer (ghost_pcm_ref p); -} - -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 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 -let ghost_write = A.ghost_write -let ghost_share = A.ghost_share -let ghost_gather = A.ghost_gather - -let return_stt_alt (#a:Type u#a) (x:a) (p:a -> slprop) -: stt a (p x ** pure (x == x)) (fun v -> p v ** pure (v == x)) -= return x (fun v -> p v ** pure (v == x)) - -let refl_stt (#a:Type u#a) (x:a) -: stt unit emp (fun _ -> pure (x == x)) -= let m : stt_ghost unit emp_inames emp (fun _ -> pure (x == x)) = intro_pure (x == x) () in - let m : stt_atomic unit #Neutral emp_inames emp (fun _ -> pure (x == x)) = lift_ghost_neutral m FStar.Tactics.Typeclasses.solve in - lift_atomic m - -let frame_flip (#pre #a #post:_) (frame:slprop) (e:stt a pre post) -: stt a (pre ** frame) (fun x -> frame ** post x) -= let i - : slprop_post_equiv (fun x -> post x ** frame) (fun x -> frame ** post x) - = intro_slprop_post_equiv _ _ (fun x -> slprop_equiv_comm (post x) frame) - in - sub_stt _ _ (slprop_equiv_refl _) i (frame_stt frame e) - -let return_stt_a (#a:Type u#a) (x:a) (p:a -> slprop) -: stt unit (p x) (fun _ -> p x ** pure (x == x)) -= elim_slprop_equiv (slprop_equiv_comm (p x) emp); - elim_slprop_equiv (slprop_equiv_unit (p x)); - frame_flip (p x) (refl_stt x) - -let return_stt (#a:Type u#a) (x:a) (p:a -> slprop) -: stt a (p x) (fun v -> p v ** pure (v == x)) -= bind_stt (return_stt_a x p) (fun _ -> return_stt_alt x p) - -//////////////////////////////////////////////////////// -// big refs -//////////////////////////////////////////////////////// -let big_pcm_pts_to #a #p r v = PulseCore.Action.big_pts_to #a #p r v -let timeless_big_pcm_pts_to #a #p r v = PulseCore.Action.timeless_big_pts_to #a #p r v -let big_pts_to_not_null #a #p r v = A.big_pts_to_not_null #a #p r v - -let big_alloc - (#a:Type) - (#pcm:pcm a) - (x:a{pcm.refine x}) -: stt (pcm_ref pcm) - emp - (fun r -> big_pcm_pts_to r x) -= A.lift_atomic (A.big_alloc #a #pcm x) - -let big_read - (#a:Type) - (#p:pcm a) - (r:pcm_ref p) - (x:erased a) - (f:(v:a{compatible p x v} - -> GTot (y:a{compatible p y v /\ - FStar.PCM.frame_compatible p x v y}))) -: stt (v:a{compatible p x v /\ p.refine v}) - (big_pcm_pts_to r x) - (fun v -> big_pcm_pts_to r (f v)) -= A.lift_atomic (A.big_read r x f) - -let big_write - (#a:Type) - (#p:pcm a) - (r:pcm_ref p) - (x y:Ghost.erased a) - (f:FStar.PCM.frame_preserving_upd p x y) -: stt unit - (big_pcm_pts_to r x) - (fun _ -> big_pcm_pts_to r y) -= A.lift_atomic (A.big_write r x y f) - -let big_share = A.big_share -let big_gather = A.big_gather - -let big_ghost_pcm_pts_to #a #p r v = PulseCore.Action.big_ghost_pts_to #a #p r v -let timeless_big_ghost_pcm_pts_to #a #p r v = PulseCore.Action.timeless_big_ghost_pts_to #a #p r v -let big_ghost_alloc = A.big_ghost_alloc -let big_ghost_read = A.big_ghost_read -let big_ghost_write = A.big_ghost_write -let big_ghost_share = A.big_ghost_share -let big_ghost_gather = A.big_ghost_gather - let as_atomic #a pre post (e:stt a pre post) = admit () // intentional since it is an assumption let unfold_check_opens = () diff --git a/lib/core/PulseCore.Action.fst b/lib/core/PulseCore.Action.fst index 00029ca72..22fad5240 100644 --- a/lib/core/PulseCore.Action.fst +++ b/lib/core/PulseCore.Action.fst @@ -448,7 +448,7 @@ let lift_eqs () Sep.lift_emp_eq() let alloc - (#a:Type u#1) + (#a:Type) (#pcm:pcm a) (x:a{pcm.refine x}) : act (ref a pcm) Atomic emp_inames emp (fun r -> pts_to r x) @@ -468,7 +468,7 @@ let read emp_inames (pts_to r x) (fun v -> pts_to r (f v)) -= lift_pre_act1_act fun #ictx -> += lift_pre_act3_act fun #ictx -> ITA.lift_mem_action (Mem.select_refine #a #p r x f) let write @@ -513,152 +513,6 @@ let gather = lift_eqs(); lift_pre_act0_act fun #ictx -> ITA.lift_mem_action (Mem.gather_action #a #pcm r v0 v1) -/////////////////////////////////////////////////////////////////// -// big refs -/////////////////////////////////////////////////////////////////// -let big_pts_to #a #pcm r x = Sep.lift (Mem.big_pts_to #a #pcm r x) -let timeless_big_pts_to #a #p r x = Sep.timeless_lift (Mem.big_pts_to #a #p r x) -let big_pts_to_not_null #a #p r v = lift_pre_act0_act fun #ictx -> - ITA.lift_mem_action (Mem.big_pts_to_not_null_action #a #p r v) - -let big_alloc - (#a:Type) - (#pcm:pcm a) - (x:a{pcm.refine x}) -: act (ref a pcm) Atomic emp_inames emp (fun r -> big_pts_to r x) -= lift_eqs(); lift_pre_act0_act fun #ictx -> - ITA.lift_mem_action (Mem.big_alloc_action #a #pcm x) - -let big_read - (#a:Type) - (#p:pcm a) - (r:ref a p) - (x:erased a) - (f:(v:a{compatible p x v} - -> GTot (y:a{compatible p y v /\ - FStar.PCM.frame_compatible p x v y}))) -: act (v:a{compatible p x v /\ p.refine v}) - Atomic - emp_inames - (big_pts_to r x) - (fun v -> big_pts_to r (f v)) -= lift_pre_act2_act fun #ictx -> - lift_eqs(); - ITA.lift_mem_action (Mem.big_select_refine#a #p r x f) - -let big_write - (#a:Type) - (#p:pcm a) - (r:ref a p) - (x y:Ghost.erased a) - (f:FStar.PCM.frame_preserving_upd p x y) -: act unit - Atomic - emp_inames - (big_pts_to r x) - (fun _ -> big_pts_to r y) -= lift_pre_act0_act fun #ictx -> - ITA.lift_mem_action (Mem.big_upd_gen #a #p r x y f) - -let big_share - (#a:Type) - (#pcm:pcm a) - (r:ref a pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a{composable pcm v0 v1}) -: act unit - Ghost - emp_inames - (big_pts_to r (v0 `op pcm` v1)) - (fun _ -> big_pts_to r v0 `star` big_pts_to r v1) -= lift_eqs(); lift_pre_act0_act fun #ictx -> - ITA.lift_mem_action (Mem.big_split_action #a #pcm r v0 v1) - -let big_gather - (#a:Type) - (#pcm:pcm a) - (r:ref a pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a) -: act (squash (composable pcm v0 v1)) - Ghost - emp_inames - (big_pts_to r v0 `star` big_pts_to r v1) - (fun _ -> big_pts_to r (op pcm v0 v1)) -= lift_eqs(); lift_pre_act0_act fun #ictx -> - ITA.lift_mem_action (Mem.big_gather_action #a #pcm r v0 v1) - -let nb_pts_to #a #pcm r x = Sep.lift <| Mem.nb_pts_to #a #pcm r x -let timeless_nb_pts_to #a #p r x = Sep.timeless_lift <| Mem.nb_pts_to #a #p r x -let nb_pts_to_not_null #a #p r v = lift_pre_act0_act fun #ictx -> - ITA.lift_mem_action (Mem.nb_pts_to_not_null_action #a #p r v) - -let nb_alloc - (#a:Type) - (#pcm:pcm a) - (x:a{pcm.refine x}) -: act (ref a pcm) Atomic emp_inames emp (fun r -> nb_pts_to r x) -= lift_eqs (); lift_pre_act0_act fun #ictx -> - ITA.lift_mem_action (Mem.nb_alloc_action #a #pcm x) - -let nb_read - (#a:Type) - (#p:pcm a) - (r:ref a p) - (x:erased a) - (f:(v:a{compatible p x v} - -> GTot (y:a{compatible p y v /\ - FStar.PCM.frame_compatible p x v y}))) -: act (v:a{compatible p x v /\ p.refine v}) - Atomic - emp_inames - (nb_pts_to r x) - (fun v -> nb_pts_to r (f v)) -= lift_pre_act3_act fun #ictx -> - ITA.lift_mem_action (Mem.nb_select_refine #a #p r x f) - -let nb_write - (#a:Type) - (#p:pcm a) - (r:ref a p) - (x y:Ghost.erased a) - (f:FStar.PCM.frame_preserving_upd p x y) -: act unit - Atomic - emp_inames - (nb_pts_to r x) - (fun _ -> nb_pts_to r y) -= lift_pre_act0_act fun #ictx -> - ITA.lift_mem_action <| Mem.nb_upd_gen #a #p r x y f - -let nb_share - (#a:Type) - (#pcm:pcm a) - (r:ref a pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a{composable pcm v0 v1}) -: act unit - Ghost - emp_inames - (nb_pts_to r (v0 `op pcm` v1)) - (fun _ -> nb_pts_to r v0 `star` nb_pts_to r v1) -= lift_eqs(); lift_pre_act0_act fun #ictx -> - ITA.lift_mem_action <| Mem.nb_split_action #a #pcm r v0 v1 - -let nb_gather - (#a:Type) - (#pcm:pcm a) - (r:ref a pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a) -: act (squash (composable pcm v0 v1)) - Ghost - emp_inames - (nb_pts_to r v0 `star` nb_pts_to r v1) - (fun _ -> nb_pts_to r (op pcm v0 v1)) -= lift_eqs(); lift_pre_act0_act fun #ictx -> - ITA.lift_mem_action <| Mem.nb_gather_action #a #pcm r v0 v1 - /////////////////////////////////////////////////////////////////// // pure @@ -733,27 +587,11 @@ 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) let ghost_alloc #a #pcm x = let open Mem in lift_eqs (); lift_pre_act0_act fun #ictx -> ITA.lift_mem_action <| ghost_alloc #a #pcm x -let ghost_read #a #p r x f = let open Mem in lift_eqs(); lift_pre_act1_act fun #ictx -> ITA.lift_mem_action <| ghost_read #a #p r x f +let ghost_read #a #p r x f = let open Mem in lift_eqs(); lift_pre_act3_act fun #ictx -> ITA.lift_mem_action <| ghost_read #a #p r x f let ghost_write #a #p r x y f = let open Mem in lift_eqs(); lift_pre_act0_act fun #ictx -> ITA.lift_mem_action <| ghost_write #a #p r x y f let ghost_share #a #pcm r v0 v1 = let open Mem in lift_eqs(); lift_pre_act0_act fun #ictx -> ITA.lift_mem_action <| ghost_share #a #pcm r v0 v1 let ghost_gather #a #pcm r v0 v1 = let open Mem in lift_eqs(); lift_pre_act0_act fun #ictx -> ITA.lift_mem_action <| ghost_gather #a #pcm r v0 v1 -let big_ghost_pts_to #a #p r x = Sep.lift (Mem.big_ghost_pts_to #a #p r x) -let timeless_big_ghost_pts_to #a #p r x = Sep.timeless_lift (Mem.big_ghost_pts_to #a #p r x) -let big_ghost_alloc #a #pcm x = let open Mem in lift_eqs(); lift_pre_act0_act fun #ictx -> ITA.lift_mem_action <| big_ghost_alloc #a #pcm x -let big_ghost_read #a #p r x f = let open Mem in lift_eqs(); lift_pre_act2_act fun #ictx -> ITA.lift_mem_action <| big_ghost_read #a #p r x f -let big_ghost_write #a #p r x y f = let open Mem in lift_eqs(); lift_pre_act0_act fun #ictx -> ITA.lift_mem_action <| big_ghost_write #a #p r x y f -let big_ghost_share #a #pcm r v0 v1 = let open Mem in lift_eqs(); lift_pre_act0_act fun #ictx -> ITA.lift_mem_action <| big_ghost_share #a #pcm r v0 v1 -let big_ghost_gather #a #pcm r v0 v1 = let open Mem in lift_eqs(); lift_pre_act0_act fun #ictx -> ITA.lift_mem_action <| big_ghost_gather #a #pcm r v0 v1 - -let nb_ghost_pts_to #a #p r x = Sep.lift (Mem.nb_ghost_pts_to #a #p r x) -let timeless_nb_ghost_pts_to #a #p r x = Sep.timeless_lift (Mem.nb_ghost_pts_to #a #p r x) -let nb_ghost_alloc #a #pcm x = let open Mem in lift_eqs(); lift_pre_act0_act fun #ictx -> ITA.lift_mem_action <| nb_ghost_alloc #a #pcm x -let nb_ghost_read #a #p r x f = let open Mem in lift_eqs(); lift_pre_act3_act fun #ictx -> ITA.lift_mem_action <| nb_ghost_read #a #p r x f -let nb_ghost_write #a #p r x y f = let open Mem in lift_eqs(); lift_pre_act0_act fun #ictx -> ITA.lift_mem_action <| nb_ghost_write #a #p r x y f -let nb_ghost_share #a #pcm r v0 v1 = let open Mem in lift_eqs(); lift_pre_act0_act fun #ictx -> ITA.lift_mem_action <| nb_ghost_share #a #pcm r v0 v1 -let nb_ghost_gather #a #pcm r v0 v1 = let open Mem in lift_eqs(); lift_pre_act0_act fun #ictx -> ITA.lift_mem_action <| nb_ghost_gather #a #pcm r v0 v1 - let lift_erased #a ni_a #opens #pre #post f = fun #ictx -> diff --git a/lib/core/PulseCore.Action.fsti b/lib/core/PulseCore.Action.fsti index 48819e7c2..fca2ec875 100644 --- a/lib/core/PulseCore.Action.fsti +++ b/lib/core/PulseCore.Action.fsti @@ -188,17 +188,17 @@ val core_ref : Type u#0 val core_ref_null : core_ref val is_core_ref_null (r:core_ref) : b:bool { b <==> r == core_ref_null } -let ref (a:Type u#a) (p:pcm a) : Type u#0 = core_ref -let ref_null (#a:Type u#a) (p:pcm a) : ref a p = core_ref_null +let ref (a:Type u#3) (p:pcm a) : Type u#0 = core_ref +let ref_null #a (p:pcm a) : ref a p = core_ref_null let is_ref_null (#a:Type) (#p:FStar.PCM.pcm a) (r:ref a p) : b:bool { b <==> r == ref_null p } = is_core_ref_null r -val pts_to (#a:Type u#1) (#p:pcm a) (r:ref a p) (v:a) : slprop +val pts_to (#a:Type) (#p:pcm a) (r:ref a p) (v:a) : slprop val timeless_pts_to - (#a:Type u#1) + (#a:Type) (#p:pcm a) (r:ref a p) (v:a) @@ -212,7 +212,7 @@ val pts_to_not_null (#a:Type) (#p:FStar.PCM.pcm a) (r:ref a p) (v:a) (fun _ -> pts_to r v) val alloc - (#a:Type u#1) + (#a:Type) (#pcm:pcm a) (x:a{pcm.refine x}) : act (ref a pcm) @@ -271,168 +271,6 @@ val gather (pts_to r v0 ** pts_to r v1) (fun _ -> pts_to r (op pcm v0 v1)) -/////////////////////////////////////////////////////////////////// -// Big references -/////////////////////////////////////////////////////////////////// - -val big_pts_to (#a:Type u#2) (#p:pcm a) (r:ref a p) (v:a) : slprop - - -val timeless_big_pts_to - (#a:Type u#2) - (#p:pcm a) - (r:ref a p) - (v:a) -: Lemma (timeless (big_pts_to r v)) - -val big_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 - emp_inames - (big_pts_to r v) - (fun _ -> big_pts_to r v) - -val big_alloc - (#a:Type) - (#pcm:pcm a) - (x:a{pcm.refine x}) -: act (ref a pcm) - Atomic - emp_inames - emp - (fun r -> big_pts_to r x) - -val big_read - (#a:Type) - (#p:pcm a) - (r:ref a p) - (x:erased a) - (f:(v:a{compatible p x v} - -> GTot (y:a{compatible p y v /\ - FStar.PCM.frame_compatible p x v y}))) -: act (v:a{compatible p x v /\ p.refine v}) - Atomic - emp_inames - (big_pts_to r x) - (fun v -> big_pts_to r (f v)) - -val big_write - (#a:Type) - (#p:pcm a) - (r:ref a p) - (x y:Ghost.erased a) - (f:FStar.PCM.frame_preserving_upd p x y) -: act unit - Atomic - emp_inames - (big_pts_to r x) - (fun _ -> big_pts_to r y) - -val big_share - (#a:Type) - (#pcm:pcm a) - (r:ref a pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a{composable pcm v0 v1}) -: act unit - Ghost - emp_inames - (big_pts_to r (v0 `op pcm` v1)) - (fun _ -> big_pts_to r v0 ** big_pts_to r v1) - -val big_gather - (#a:Type) - (#pcm:pcm a) - (r:ref a pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a) -: act (squash (composable pcm v0 v1)) - Ghost - emp_inames - (big_pts_to r v0 ** big_pts_to r v1) - (fun _ -> big_pts_to r (op pcm v0 v1)) - -/////////////////////////////////////////////////////////////////// -// Non-boxable references -/////////////////////////////////////////////////////////////////// - -val nb_pts_to (#a:Type u#3) (#p:pcm a) (r:ref a p) (v:a) : slprop - - -val timeless_nb_pts_to - (#a:Type u#3) - (#p:pcm a) - (r:ref a p) - (v:a) -: Lemma (timeless (nb_pts_to r v)) - -val nb_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 - emp_inames - (nb_pts_to r v) - (fun _ -> nb_pts_to r v) - -val nb_alloc - (#a:Type) - (#pcm:pcm a) - (x:a{pcm.refine x}) -: act (ref a pcm) - Atomic - emp_inames - emp - (fun r -> nb_pts_to r x) - -val nb_read - (#a:Type) - (#p:pcm a) - (r:ref a p) - (x:erased a) - (f:(v:a{compatible p x v} - -> GTot (y:a{compatible p y v /\ - FStar.PCM.frame_compatible p x v y}))) -: act (v:a{compatible p x v /\ p.refine v}) - Atomic - emp_inames - (nb_pts_to r x) - (fun v -> nb_pts_to r (f v)) - -val nb_write - (#a:Type) - (#p:pcm a) - (r:ref a p) - (x y:Ghost.erased a) - (f:FStar.PCM.frame_preserving_upd p x y) -: act unit - Atomic - emp_inames - (nb_pts_to r x) - (fun _ -> nb_pts_to r y) - -val nb_share - (#a:Type) - (#pcm:pcm a) - (r:ref a pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a{composable pcm v0 v1}) -: act unit - Ghost - emp_inames - (nb_pts_to r (v0 `op pcm` v1)) - (fun _ -> nb_pts_to r v0 ** nb_pts_to r v1) - -val nb_gather - (#a:Type) - (#pcm:pcm a) - (r:ref a pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a) -: act (squash (composable pcm v0 v1)) - Ghost - emp_inames - (nb_pts_to r v0 ** nb_pts_to r v1) - (fun _ -> nb_pts_to r (op pcm v0 v1)) - /////////////////////////////////////////////////////////////////// // pure /////////////////////////////////////////////////////////////////// @@ -466,17 +304,17 @@ val drop (p:slprop) [@@erasable] val core_ghost_ref : Type u#0 val core_ghost_ref_null : core_ghost_ref -let ghost_ref (#a:Type u#a) (p:pcm a) : Type u#0 = core_ghost_ref -val ghost_pts_to (#a:Type u#1) (#p:pcm a) (r:ghost_ref p) (v:a) : slprop +let ghost_ref (#a:Type u#3) (p:pcm a) : Type u#0 = core_ghost_ref +val ghost_pts_to (#a:Type) (#p:pcm a) (r:ghost_ref p) (v:a) : slprop val timeless_ghost_pts_to - (#a:Type u#1) + (#a:Type) (#p:pcm a) (r:ghost_ref p) (v:a) : Lemma (timeless (ghost_pts_to r v)) -val ghost_pts_to_not_null (#a:Type u#1) (#p:FStar.PCM.pcm a) (r:ghost_ref p) (v:a) +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 emp_inames @@ -484,7 +322,7 @@ val ghost_pts_to_not_null (#a:Type u#1) (#p:FStar.PCM.pcm a) (r:ghost_ref p) (v: (fun _ -> ghost_pts_to r v) val ghost_alloc - (#a:Type u#1) + (#a:Type) (#pcm:pcm a) (x:erased a{pcm.refine x}) : act (ghost_ref pcm) Ghost emp_inames @@ -533,127 +371,6 @@ val ghost_gather (ghost_pts_to r v0 ** ghost_pts_to r v1) (fun _ -> ghost_pts_to r (op pcm v0 v1)) -val big_ghost_pts_to (#a:Type u#2) (#p:pcm a) (r:ghost_ref p) (v:a) : slprop - - -val timeless_big_ghost_pts_to - (#a:Type u#2) - (#p:pcm a) - (r:ghost_ref p) - (v:a) -: Lemma (timeless (big_ghost_pts_to r v)) - -val big_ghost_alloc - (#a:Type) - (#pcm:pcm a) - (x:erased a{pcm.refine x}) -: act (ghost_ref pcm) Ghost emp_inames - emp - (fun r -> big_ghost_pts_to r x) - -val big_ghost_read - (#a:Type) - (#p:pcm a) - (r:ghost_ref p) - (x:erased a) - (f:(v:a{compatible p x v} - -> GTot (y:a{compatible p y v /\ - FStar.PCM.frame_compatible p x v y}))) -: act (erased (v:a{compatible p x v /\ p.refine v})) Ghost emp_inames - (big_ghost_pts_to r x) - (fun v -> big_ghost_pts_to r (f v)) - -val big_ghost_write - (#a:Type) - (#p:pcm a) - (r:ghost_ref p) - (x y:Ghost.erased a) - (f:FStar.PCM.frame_preserving_upd p x y) -: act unit Ghost emp_inames - (big_ghost_pts_to r x) - (fun _ -> big_ghost_pts_to r y) - -val big_ghost_share - (#a:Type) - (#pcm:pcm a) - (r:ghost_ref pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a{composable pcm v0 v1}) -: act unit Ghost emp_inames - (big_ghost_pts_to r (v0 `op pcm` v1)) - (fun _ -> big_ghost_pts_to r v0 ** big_ghost_pts_to r v1) - -val big_ghost_gather - (#a:Type) - (#pcm:pcm a) - (r:ghost_ref pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a) -: act (squash (composable pcm v0 v1)) Ghost emp_inames - (big_ghost_pts_to r v0 ** big_ghost_pts_to r v1) - (fun _ -> big_ghost_pts_to r (op pcm v0 v1)) - -// Non-boxable ghost references -val nb_ghost_pts_to (#a:Type u#3) (#p:pcm a) (r:ghost_ref p) (v:a) : slprop - - -val timeless_nb_ghost_pts_to - (#a:Type u#3) - (#p:pcm a) - (r:ghost_ref p) - (v:a) -: Lemma (timeless (nb_ghost_pts_to r v)) - -val nb_ghost_alloc - (#a:Type) - (#pcm:pcm a) - (x:erased a{pcm.refine x}) -: act (ghost_ref pcm) Ghost emp_inames - emp - (fun r -> nb_ghost_pts_to r x) - -val nb_ghost_read - (#a:Type) - (#p:pcm a) - (r:ghost_ref p) - (x:erased a) - (f:(v:a{compatible p x v} - -> GTot (y:a{compatible p y v /\ - FStar.PCM.frame_compatible p x v y}))) -: act (erased (v:a{compatible p x v /\ p.refine v})) Ghost emp_inames - (nb_ghost_pts_to r x) - (fun v -> nb_ghost_pts_to r (f v)) - -val nb_ghost_write - (#a:Type) - (#p:pcm a) - (r:ghost_ref p) - (x y:Ghost.erased a) - (f:FStar.PCM.frame_preserving_upd p x y) -: act unit Ghost emp_inames - (nb_ghost_pts_to r x) - (fun _ -> nb_ghost_pts_to r y) - -val nb_ghost_share - (#a:Type) - (#pcm:pcm a) - (r:ghost_ref pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a{composable pcm v0 v1}) -: act unit Ghost emp_inames - (nb_ghost_pts_to r (v0 `op pcm` v1)) - (fun _ -> nb_ghost_pts_to r v0 ** nb_ghost_pts_to r v1) - -val nb_ghost_gather - (#a:Type) - (#pcm:pcm a) - (r:ghost_ref pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a) -: act (squash (composable pcm v0 v1)) Ghost emp_inames - (nb_ghost_pts_to r v0 ** nb_ghost_pts_to r v1) - (fun _ -> nb_ghost_pts_to r (op pcm v0 v1)) - //////////////////////////////////////////////////////////////////////// let non_informative a = x:erased a -> y:a { reveal x == y} diff --git a/lib/core/PulseCore.Atomic.fst b/lib/core/PulseCore.Atomic.fst index ccd1100ff..3cc0df789 100644 --- a/lib/core/PulseCore.Atomic.fst +++ b/lib/core/PulseCore.Atomic.fst @@ -316,34 +316,6 @@ let ghost_write r x y f = lift_neutral_ghost (A.ghost_write r x y f) let ghost_share r v0 v1 = lift_neutral_ghost (A.ghost_share r v0 v1) let ghost_gather r v0 v1 = lift_neutral_ghost (A.ghost_gather r v0 v1) -let big_pts_to_not_null #a #p r v = lift_neutral_ghost (A.big_pts_to_not_null #a #p r v) -let big_alloc #a #pcm x = A.big_alloc x -let big_read r x f = A.big_read r x f -let big_write r x y f = A.big_write r x y f -let big_share #a #pcm r v0 v1 = lift_neutral_ghost (A.big_share r v0 v1) -let big_gather #a #pcm r v0 v1 = lift_neutral_ghost (A.big_gather r v0 v1) - - -let big_ghost_alloc #a #pcm x = lift_neutral_ghost <| A.big_ghost_alloc #a #pcm x -let big_ghost_read #a #p r x f = lift_neutral_ghost <| A.big_ghost_read r x f -let big_ghost_write r x y f = lift_neutral_ghost (A.big_ghost_write r x y f) -let big_ghost_share r v0 v1 = lift_neutral_ghost (A.big_ghost_share r v0 v1) -let big_ghost_gather r v0 v1 = lift_neutral_ghost (A.big_ghost_gather r v0 v1) - -let nb_pts_to_not_null #a #p r v = lift_neutral_ghost (A.nb_pts_to_not_null #a #p r v) -let nb_alloc #a #pcm x = A.nb_alloc x -let nb_read r x f = A.nb_read r x f -let nb_write r x y f = A.nb_write r x y f -let nb_share #a #pcm r v0 v1 = lift_neutral_ghost (A.nb_share r v0 v1) -let nb_gather #a #pcm r v0 v1 = lift_neutral_ghost (A.nb_gather r v0 v1) - - -let nb_ghost_alloc #a #pcm x = lift_neutral_ghost <| A.nb_ghost_alloc #a #pcm x -let nb_ghost_read #a #p r x f = lift_neutral_ghost <| A.nb_ghost_read r x f -let nb_ghost_write r x y f = lift_neutral_ghost (A.nb_ghost_write r x y f) -let nb_ghost_share r v0 v1 = lift_neutral_ghost (A.nb_ghost_share r v0 v1) -let nb_ghost_gather r v0 v1 = lift_neutral_ghost (A.nb_ghost_gather r v0 v1) - let drop p = lift_neutral_ghost (A.drop p) let equiv_refl a = lift_neutral_ghost (A.equiv_refl a) diff --git a/lib/core/PulseCore.Atomic.fsti b/lib/core/PulseCore.Atomic.fsti index d662adcd8..b68999db0 100644 --- a/lib/core/PulseCore.Atomic.fsti +++ b/lib/core/PulseCore.Atomic.fsti @@ -312,7 +312,7 @@ val buy1 () open FStar.PCM val pts_to_not_null - (#a:Type u#1) + (#a:Type) (#p:FStar.PCM.pcm a) (r:ref a p) (v:a) @@ -322,7 +322,7 @@ val pts_to_not_null (fun _ -> pts_to r v) val alloc - (#a:Type u#1) + (#a:Type) (#pcm:pcm a) (x:a{pcm.refine x}) : stt_atomic (ref a pcm) @@ -383,7 +383,7 @@ val gather // Ghost References //////////////////////////////////////////////////////////////////////// val ghost_pts_to_not_null - (#a:Type u#1) + (#a:Type) (#p:FStar.PCM.pcm a) (r:ghost_ref p) (v:a) @@ -393,7 +393,7 @@ val ghost_pts_to_not_null (fun _ -> ghost_pts_to r v) val ghost_alloc - (#a:Type u#1) + (#a:Type) (#pcm:pcm a) (x:erased a{pcm.refine x}) : stt_ghost (ghost_ref pcm) @@ -447,261 +447,6 @@ val ghost_gather (ghost_pts_to r v0 ** ghost_pts_to r v1) (fun _ -> ghost_pts_to r (op pcm v0 v1)) -//////////////////////////////////////////////////////////////////////// -// Big References -//////////////////////////////////////////////////////////////////////// - -val big_pts_to_not_null - (#a:Type) - (#p:FStar.PCM.pcm a) - (r:ref a p) - (v:a) -: stt_ghost (squash (not (is_ref_null r))) - emp_inames - (big_pts_to r v) - (fun _ -> big_pts_to r v) - -val big_alloc - (#a:Type) - (#pcm:pcm a) - (x:a{pcm.refine x}) -: stt_atomic (ref a pcm) - #Observable - emp_inames - emp - (fun r -> big_pts_to r x) - -val big_read - (#a:Type) - (#p:pcm a) - (r:ref a p) - (x:erased a) - (f:(v:a{compatible p x v} - -> GTot (y:a{compatible p y v /\ - FStar.PCM.frame_compatible p x v y}))) -: stt_atomic (v:a{compatible p x v /\ p.refine v}) - #Observable - emp_inames - (big_pts_to r x) - (fun v -> big_pts_to r (f v)) - -val big_write - (#a:Type) - (#p:pcm a) - (r:ref a p) - (x y:Ghost.erased a) - (f:FStar.PCM.frame_preserving_upd p x y) -: stt_atomic unit - #Observable - emp_inames - (big_pts_to r x) - (fun _ -> big_pts_to r y) - -val big_share - (#a:Type) - (#pcm:pcm a) - (r:ref a pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a{composable pcm v0 v1}) -: stt_ghost unit - emp_inames - (big_pts_to r (v0 `op pcm` v1)) - (fun _ -> big_pts_to r v0 ** big_pts_to r v1) - -val big_gather - (#a:Type) - (#pcm:pcm a) - (r:ref a pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a) -: stt_ghost (squash (composable pcm v0 v1)) - emp_inames - (big_pts_to r v0 ** big_pts_to r v1) - (fun _ -> big_pts_to r (op pcm v0 v1)) - -val big_ghost_alloc - (#a:Type) - (#pcm:pcm a) - (x:erased a{pcm.refine x}) -: stt_ghost (ghost_ref pcm) - emp_inames - emp - (fun r -> big_ghost_pts_to r x) - -val big_ghost_read - (#a:Type) - (#p:pcm a) - (r:ghost_ref p) - (x:erased a) - (f:(v:a{compatible p x v} - -> GTot (y:a{compatible p y v /\ - FStar.PCM.frame_compatible p x v y}))) -: stt_ghost (erased (v:a{compatible p x v /\ p.refine v})) - emp_inames - (big_ghost_pts_to r x) - (fun v -> big_ghost_pts_to r (f v)) - -val big_ghost_write - (#a:Type) - (#p:pcm a) - (r:ghost_ref p) - (x y:Ghost.erased a) - (f:FStar.PCM.frame_preserving_upd p x y) -: stt_ghost unit - emp_inames - (big_ghost_pts_to r x) - (fun _ -> big_ghost_pts_to r y) - -val big_ghost_share - (#a:Type) - (#pcm:pcm a) - (r:ghost_ref pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a{composable pcm v0 v1}) -: stt_ghost unit - emp_inames - (big_ghost_pts_to r (v0 `op pcm` v1)) - (fun _ -> big_ghost_pts_to r v0 ** big_ghost_pts_to r v1) - -val big_ghost_gather - (#a:Type) - (#pcm:pcm a) - (r:ghost_ref pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a) -: stt_ghost (squash (composable pcm v0 v1)) - emp_inames - (big_ghost_pts_to r v0 ** big_ghost_pts_to r v1) - (fun _ -> big_ghost_pts_to r (op pcm v0 v1)) - - -//////////////////////////////////////////////////////////////////////// -// Non-boxable References -//////////////////////////////////////////////////////////////////////// - -val nb_pts_to_not_null - (#a:Type) - (#p:FStar.PCM.pcm a) - (r:ref a p) - (v:a) -: stt_ghost (squash (not (is_ref_null r))) - emp_inames - (nb_pts_to r v) - (fun _ -> nb_pts_to r v) - -val nb_alloc - (#a:Type) - (#pcm:pcm a) - (x:a{pcm.refine x}) -: stt_atomic (ref a pcm) - #Observable - emp_inames - emp - (fun r -> nb_pts_to r x) - -val nb_read - (#a:Type) - (#p:pcm a) - (r:ref a p) - (x:erased a) - (f:(v:a{compatible p x v} - -> GTot (y:a{compatible p y v /\ - FStar.PCM.frame_compatible p x v y}))) -: stt_atomic (v:a{compatible p x v /\ p.refine v}) - #Observable - emp_inames - (nb_pts_to r x) - (fun v -> nb_pts_to r (f v)) - -val nb_write - (#a:Type) - (#p:pcm a) - (r:ref a p) - (x y:Ghost.erased a) - (f:FStar.PCM.frame_preserving_upd p x y) -: stt_atomic unit - #Observable - emp_inames - (nb_pts_to r x) - (fun _ -> nb_pts_to r y) - -val nb_share - (#a:Type) - (#pcm:pcm a) - (r:ref a pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a{composable pcm v0 v1}) -: stt_ghost unit - emp_inames - (nb_pts_to r (v0 `op pcm` v1)) - (fun _ -> nb_pts_to r v0 ** nb_pts_to r v1) - -val nb_gather - (#a:Type) - (#pcm:pcm a) - (r:ref a pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a) -: stt_ghost (squash (composable pcm v0 v1)) - emp_inames - (nb_pts_to r v0 ** nb_pts_to r v1) - (fun _ -> nb_pts_to r (op pcm v0 v1)) - -val nb_ghost_alloc - (#a:Type) - (#pcm:pcm a) - (x:erased a{pcm.refine x}) -: stt_ghost (ghost_ref pcm) - emp_inames - emp - (fun r -> nb_ghost_pts_to r x) - -val nb_ghost_read - (#a:Type) - (#p:pcm a) - (r:ghost_ref p) - (x:erased a) - (f:(v:a{compatible p x v} - -> GTot (y:a{compatible p y v /\ - FStar.PCM.frame_compatible p x v y}))) -: stt_ghost (erased (v:a{compatible p x v /\ p.refine v})) - emp_inames - (nb_ghost_pts_to r x) - (fun v -> nb_ghost_pts_to r (f v)) - -val nb_ghost_write - (#a:Type) - (#p:pcm a) - (r:ghost_ref p) - (x y:Ghost.erased a) - (f:FStar.PCM.frame_preserving_upd p x y) -: stt_ghost unit - emp_inames - (nb_ghost_pts_to r x) - (fun _ -> nb_ghost_pts_to r y) - -val nb_ghost_share - (#a:Type) - (#pcm:pcm a) - (r:ghost_ref pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a{composable pcm v0 v1}) -: stt_ghost unit - emp_inames - (nb_ghost_pts_to r (v0 `op pcm` v1)) - (fun _ -> nb_ghost_pts_to r v0 ** nb_ghost_pts_to r v1) - -val nb_ghost_gather - (#a:Type) - (#pcm:pcm a) - (r:ghost_ref pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a) -: stt_ghost (squash (composable pcm v0 v1)) - emp_inames - (nb_ghost_pts_to r v0 ** nb_ghost_pts_to r v1) - (fun _ -> nb_ghost_pts_to r (op pcm v0 v1)) - val drop (p:slprop) : stt_ghost unit emp_inames p (fun _ -> emp) diff --git a/lib/core/PulseCore.BaseHeapSig.fst b/lib/core/PulseCore.BaseHeapSig.fst index 47fd9cbc0..03fe99529 100644 --- a/lib/core/PulseCore.BaseHeapSig.fst +++ b/lib/core/PulseCore.BaseHeapSig.fst @@ -247,53 +247,6 @@ let gather #a #p r x y = #(fun _ -> pts_to r (op p x y)) let pts_to_not_null_action #a #p r x = lift_heap_action (H2.pts_to_not_null_action #a #p r x) -module U = Pulse.Lib.Raise -module R = Pulse.Lib.PCM.Raise - -let ghost_pts_to' #a #p r x = - H2.ghost_pts_to #(U.raise_t a) #(R.raise p) r (U.raise_val x) - -let ghost_extend' #a #p x = fun frame m0 -> - ghost_extend #_ #(R.raise p) (U.raise_val (reveal x)) frame m0 - -let ghost_read' #a #p r x f = fun frame m0 -> - let y, m0 = ghost_read #_ #(R.raise p) r (U.raise_val (reveal x)) (R.raise_refine p x f) frame m0 in - hide (U.downgrade_val y), m0 - -let ghost_write' #a #p r x y f = - ghost_write #_ #(R.raise p) r (U.raise_val (reveal x)) (U.raise_val (reveal y)) (R.raise_upd f) - -let ghost_share' #a #p r x y = - ghost_share #_ #(R.raise p) r (U.raise_val (reveal x)) (U.raise_val (reveal y)) - -let ghost_gather' #a #p r x y = - ghost_gather #_ #(R.raise p) r (U.raise_val (reveal x)) (U.raise_val (reveal y)) - -let ghost_pts_to_not_null_action' #a #p r v = - ghost_pts_to_not_null_action #_ #(R.raise p) r (U.raise_val (reveal v)) - -let pts_to' #a #p r x = - H2.pts_to #(U.raise_t a) #(R.raise p) r (U.raise_val x) - -let extend' #a #p x = fun frame m0 -> - extend #_ #(R.raise p) (U.raise_val x) frame m0 - -let read' #a #p r x f = fun frame m0 -> - let y, m0 = read #_ #(R.raise p) r (U.raise_val (reveal x)) (R.raise_refine p x f) frame m0 in - U.downgrade_val y, m0 - -let write' #a #p r x y f = - write #_ #(R.raise p) r (U.raise_val (reveal x)) (U.raise_val (reveal y)) (R.raise_upd f) - -let share' #a #p r x y = - share #_ #(R.raise p) r (U.raise_val (reveal x)) (U.raise_val (reveal y)) - -let gather' #a #p r x y = - gather #_ #(R.raise p) r (U.raise_val (reveal x)) (U.raise_val (reveal y)) - -let pts_to_not_null_action' #a #p r v = - pts_to_not_null_action #_ #(R.raise p) r (U.raise_val (reveal v)) - let lift_ghost (#a:Type u#a) (#p:slprop u#b) diff --git a/lib/core/PulseCore.BaseHeapSig.fsti b/lib/core/PulseCore.BaseHeapSig.fsti index 5affa910c..6ce9f515b 100644 --- a/lib/core/PulseCore.BaseHeapSig.fsti +++ b/lib/core/PulseCore.BaseHeapSig.fsti @@ -248,124 +248,6 @@ val pts_to_not_null_action (pts_to r v) (fun _ -> pts_to r v) -val ghost_pts_to' (#a:Type u#a) (#p:pcm a) (r:ghost_ref a p) (x:a) : slprop u#(max a b) - -val ghost_extend' - (#a:Type u#a) - (#pcm:pcm a) - (x:erased a{pcm.refine x}) -: ghost_action_except (ghost_ref a pcm) emp (fun r -> ghost_pts_to' u#a u#b r x) - -val ghost_read' - (#a:Type) - (#p:pcm a) - (r:ghost_ref a p) - (x:erased a) - (f:(v:a{compatible p x v} - -> GTot (y:a{compatible p y v /\ - FStar.PCM.frame_compatible p x v y}))) -: ghost_action_except (erased (v:a{compatible p x v /\ p.refine v})) - (ghost_pts_to' u#a u#b r x) - (fun v -> ghost_pts_to' u#a u#b r (f v)) - -val ghost_write' - (#a:Type) - (#p:pcm a) - (r:ghost_ref a p) - (x y:Ghost.erased a) - (f:FStar.PCM.frame_preserving_upd p x y) -: ghost_action_except unit - (ghost_pts_to' u#a u#b r x) - (fun _ -> ghost_pts_to' u#a u#b r y) - -val ghost_share' - (#a:Type) - (#pcm:pcm a) - (r:ghost_ref a pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a{composable pcm v0 v1}) -: ghost_action_except unit - (ghost_pts_to' u#a u#b r (v0 `op pcm` v1)) - (fun _ -> ghost_pts_to' u#a u#b r v0 `star` ghost_pts_to' u#a u#b r v1) - -val ghost_gather' - (#a:Type) - (#pcm:pcm a) - (r:ghost_ref a pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a) -: ghost_action_except (squash (composable pcm v0 v1)) - (ghost_pts_to' u#a u#b r v0 `star` ghost_pts_to' u#a u#b r v1) - (fun _ -> ghost_pts_to' u#a u#b r (op pcm v0 v1)) - -val ghost_pts_to_not_null_action' - (#a:Type u#a) - (#pcm:pcm a) - (r:ghost_ref a pcm) - (v:Ghost.erased a) -: ghost_action_except (squash (r =!= core_ghost_ref_null)) - (ghost_pts_to' u#a u#b r v) - (fun _ -> ghost_pts_to' u#a u#b r v) - -val pts_to' (#a:Type u#a) (#p:pcm a) (r:ref a p) (x:a) : slprop u#(max a b) - -val extend' - (#a:Type) - (#pcm:pcm a) - (x:a{pcm.refine x}) -: action_except (ref a pcm) emp (fun r -> pts_to' u#a u#b r x) - -val read' - (#a:Type) - (#p:pcm a) - (r:ref a p) - (x:erased a) - (f:(v:a{compatible p x v} - -> GTot (y:a{compatible p y v /\ - FStar.PCM.frame_compatible p x v y}))) -: action_except (v:a{compatible p x v /\ p.refine v}) - (pts_to' u#a u#b r x) - (fun v -> pts_to' u#a u#b r (f v)) - -val write' - (#a:Type) - (#p:pcm a) - (r:ref a p) - (x y:Ghost.erased a) - (f:FStar.PCM.frame_preserving_upd p x y) -: action_except unit - (pts_to' u#a u#b r x) - (fun _ -> pts_to' u#a u#b r y) - -val share' - (#a:Type) - (#pcm:pcm a) - (r:ref a pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a{composable pcm v0 v1}) -: ghost_action_except unit - (pts_to' u#a u#b r (v0 `op pcm` v1)) - (fun _ -> pts_to' u#a u#b r v0 `star` pts_to' u#a u#b r v1) - -val gather' - (#a:Type) - (#pcm:pcm a) - (r:ref a pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a) -: ghost_action_except (squash (composable pcm v0 v1)) - (pts_to' u#a u#b r v0 `star` pts_to' u#a u#b r v1) - (fun _ -> pts_to' u#a u#b r (op pcm v0 v1)) - -val pts_to_not_null_action' - (#a:Type u#a) - (#pcm:pcm a) - (r:erased (ref a pcm)) - (v:Ghost.erased a) -: ghost_action_except (squash (not (is_null r))) - (pts_to' u#a u#b r v) - (fun _ -> pts_to' u#a u#b r v) - val lift_ghost (#a:Type u#a) (#p:slprop u#b) diff --git a/lib/core/PulseCore.Heap2.fst b/lib/core/PulseCore.Heap2.fst index 60b91c5ae..0c2ba0907 100644 --- a/lib/core/PulseCore.Heap2.fst +++ b/lib/core/PulseCore.Heap2.fst @@ -401,9 +401,6 @@ let change_slprop (p q:slprop) in refined_pre_action_as_action g - -module U = Pulse.Lib.Raise - let elim_pure (p:prop) : action (pure p) (u:unit{p}) (fun _ -> emp) = let f diff --git a/lib/core/PulseCore.IndirectionTheoryActions.fst b/lib/core/PulseCore.IndirectionTheoryActions.fst index fb2b8a5b2..cbed7c167 100644 --- a/lib/core/PulseCore.IndirectionTheoryActions.fst +++ b/lib/core/PulseCore.IndirectionTheoryActions.fst @@ -534,20 +534,6 @@ let intro_exists (#opened_invariants:_) (#a:_) (p:a -> slprop) (x:erased a) is_ghost_action_refl s0; (), s0 -let raise_exists (#opened_invariants:_) (#a:Type u#a) (p:a -> slprop) -: ghost_act unit opened_invariants - (op_exists_Star p) - (fun _a -> op_exists_Star #(U.raise_t u#a u#b a) (U.lift_dom u#a u#b u#_ p)) -= fun frame s0 -> - let x, s1 = witness_exists #opened_invariants #a p frame s0 in - sep_laws(); - let m1, m2 = split_mem (p x) (frame `star` mem_invariant opened_invariants s1) s1 in - assert (interp ((U.lift_dom p) (U.raise_val u#a u#b (reveal x))) m1); - interp_exists (U.lift_dom u#a u#b u#_ p); - assert (interp (op_exists_Star #(U.raise_t u#a u#b a) (U.lift_dom p)) m1); - star_equiv (op_exists_Star #(U.raise_t u#a u#b a) (U.lift_dom p)) (frame `star` mem_invariant opened_invariants s1) s1; - (), s1 - let elim_pure (#opened_invariants:_) (p:prop) : ghost_act (u:unit{p}) opened_invariants (pure p) (fun _ -> emp) = fun frame s0 -> diff --git a/lib/core/PulseCore.IndirectionTheoryActions.fsti b/lib/core/PulseCore.IndirectionTheoryActions.fsti index fd440962e..6a65fbc69 100644 --- a/lib/core/PulseCore.IndirectionTheoryActions.fsti +++ b/lib/core/PulseCore.IndirectionTheoryActions.fsti @@ -101,7 +101,6 @@ val frame (#a:Type) : _act_except a ak opened_invariants (pre `star` frame) (fun x -> post x `star` frame) open FStar.Ghost -module U = Pulse.Lib.Raise val witness_exists (#opened_invariants:_) (#a:_) (p:a -> slprop) : ghost_act (erased a) opened_invariants (op_exists_Star p) @@ -112,11 +111,6 @@ val intro_exists (#opened_invariants:_) (#a:_) (p:a -> slprop) (x:erased a) (p x) (fun _ -> op_exists_Star p) -val raise_exists (#opened_invariants:_) (#a:Type u#a) {| U.raisable u#a u#b |} (p:a -> slprop) -: ghost_act unit opened_invariants - (op_exists_Star p) - (fun _a -> op_exists_Star #(U.raise_t u#a u#b a) (U.lift_dom p)) - val elim_pure (#opened_invariants:_) (p:prop) : ghost_act (u:unit{p}) opened_invariants (pure p) (fun _ -> emp) diff --git a/lib/core/PulseCore.MemoryAlt.fst b/lib/core/PulseCore.MemoryAlt.fst index 8a15d36f5..ffa836a44 100644 --- a/lib/core/PulseCore.MemoryAlt.fst +++ b/lib/core/PulseCore.MemoryAlt.fst @@ -17,7 +17,6 @@ module PulseCore.MemoryAlt open FStar.Ghost open FStar.PCM -module U = Pulse.Lib.Raise module CM = FStar.Algebra.CommMonoid module B = PulseCore.BaseHeapSig @@ -111,57 +110,23 @@ let lift_ghost = B.lift_ghost #_ #(p) #(fun x -> q x) ni_a (coerce_action_back _ _ () f) -(* Concrete references to "small" types *) -let pts_to = B.pts_to' u#(a+1) u#(a+3) +(* Concrete references *) +let pts_to = B.pts_to u#(a+3) +let split_action = B.share u#(a+3) +let gather_action = B.gather u#(a+3) +let alloc_action = B.extend u#(a+3) +let select_refine = B.read u#(a+3) +let upd_gen = B.write u#(a+3) +let pts_to_not_null_action = B.pts_to_not_null_action u#(a+3) -let split_action = B.share' u#(a+1) u#(a+3) -let gather_action = B.gather' u#(a+1) u#(a+3) -let alloc_action = B.extend' u#(a+1) u#(a+3) -let select_refine = B.read' u#(a+1) u#(a+3) -let upd_gen = B.write' u#(a+1) u#(a+3) -let pts_to_not_null_action = B.pts_to_not_null_action' u#(a+1) u#(a+3) - -(* Ghost references to "small" types *) +(* Ghost references *) [@@erasable] let core_ghost_ref : Type0 = B.core_ghost_ref let core_ghost_ref_null = PulseCore.Heap2.core_ghost_ref_null -let ghost_pts_to = B.ghost_pts_to' u#(a+1) u#(a+3) -let ghost_alloc = B.ghost_extend' u#(a+1) u#(a+3) -let ghost_read = B.ghost_read' u#(a+1) u#(a+3) -let ghost_write = B.ghost_write' u#(a+1) u#(a+3) -let ghost_share = B.ghost_share' u#(a+1) u#(a+3) -let ghost_gather = B.ghost_gather' u#(a+1) u#(a+3) -let ghost_pts_to_not_null_action #a #pcm = B.ghost_pts_to_not_null_action' u#(a+1) u#(a+3) #a #pcm - -(* Concrete references to "big" types *) -let big_pts_to = B.pts_to' u#(a+2) u#(a+3) -let big_split_action = B.share' u#(a+2) u#(a+3) -let big_gather_action = B.gather' u#(a+2) u#(a+3) -let big_alloc_action = B.extend' u#(a+2) u#(a+3) -let big_select_refine = B.read' u#(a+2) u#(a+3) -let big_upd_gen = B.write' u#(a+2) u#(a+3) -let big_pts_to_not_null_action = B.pts_to_not_null_action' u#(a+2) u#(a+3) - -(* Ghost references to "big" types *) -let big_ghost_pts_to = B.ghost_pts_to' u#(a+2) u#(a+3) -let big_ghost_alloc = B.ghost_extend' u#(a+2) u#(a+3) -let big_ghost_read = B.ghost_read' u#(a+2) u#(a+3) -let big_ghost_write = B.ghost_write' u#(a+2) u#(a+3) -let big_ghost_share = B.ghost_share' u#(a+2) u#(a+3) -let big_ghost_gather = B.ghost_gather' u#(a+2) u#(a+3) - - (* References for objects in universes a+3, "non-boxable" pts_to *) -let nb_pts_to = B.pts_to u#(a+3) -let nb_split_action = B.share u#(a+3) -let nb_gather_action = B.gather u#(a+3) -let nb_alloc_action = B.extend u#(a+3) -let nb_select_refine = B.read u#(a+3) -let nb_upd_gen = B.write u#(a+3) -let nb_pts_to_not_null_action = B.pts_to_not_null_action u#(a+3) - -let nb_ghost_pts_to = B.ghost_pts_to u#(a+3) -let nb_ghost_alloc = B.ghost_extend u#(a+3) -let nb_ghost_read = B.ghost_read u#(a+3) -let nb_ghost_write = B.ghost_write u#(a+3) -let nb_ghost_share = B.ghost_share u#(a+3) -let nb_ghost_gather = B.ghost_gather u#(a+3) \ No newline at end of file +let ghost_pts_to = B.ghost_pts_to u#(a+3) +let ghost_alloc = B.ghost_extend u#(a+3) +let ghost_read = B.ghost_read u#(a+3) +let ghost_write = B.ghost_write u#(a+3) +let ghost_share = B.ghost_share u#(a+3) +let ghost_gather = B.ghost_gather u#(a+3) +let ghost_pts_to_not_null_action #a #pcm = B.ghost_pts_to_not_null_action u#(a+3) #a #pcm \ No newline at end of file diff --git a/lib/core/PulseCore.MemoryAlt.fsti b/lib/core/PulseCore.MemoryAlt.fsti index b177a0d0c..b06bcfa57 100644 --- a/lib/core/PulseCore.MemoryAlt.fsti +++ b/lib/core/PulseCore.MemoryAlt.fsti @@ -18,7 +18,6 @@ module PulseCore.MemoryAlt open FStar.Ghost open FStar.PCM module PST = PulseCore.HoareStateMonad -module U = Pulse.Lib.Raise module CM = FStar.Algebra.CommMonoid module B = PulseCore.BaseHeapSig @@ -61,7 +60,7 @@ val slprop_equiv_refl (p:slprop) (** A memory maps a [ref]erence to its associated value *) val core_ref : Type u#0 -let ref (a:Type u#a) (pcm:pcm a) : Type u#0 = core_ref +let ref (a:Type u#(a+3)) (pcm:pcm a) : Type u#0 = core_ref (** [null] is a specific reference, that is not associated to any value *) @@ -69,13 +68,13 @@ val core_ref_null : core_ref (** [null] is a specific reference, that is not associated to any value *) -let null (#a:Type u#a) (#pcm:pcm a) : ref a pcm = core_ref_null +let null (#a:Type) (#pcm:pcm a) : ref a pcm = core_ref_null val core_ref_is_null (r:core_ref) : b:bool { b <==> r == core_ref_null } (** Checking whether [r] is the null pointer is decidable through [is_null] *) -let is_null (#a:Type u#a) (#pcm:pcm a) (r:ref a pcm) : (b:bool{b <==> r == null}) = core_ref_is_null r +let is_null (#a:Type) (#pcm:pcm a) (r:ref a pcm) : (b:bool{b <==> r == null}) = core_ref_is_null r (** All the standard connectives of separation logic, based on [Steel.Heap] *) let emp : slprop u#a = B.emp @@ -157,11 +156,11 @@ val lift_ghost : pst_ghost_action_except a p q (* Concrete references to "small" types *) -val pts_to (#a:Type u#(a+1)) (#pcm:_) (r:ref a pcm) (v:a) : slprop u#a +val pts_to (#a:Type u#(a+3)) (#pcm:_) (r:ref a pcm) (v:a) : slprop u#a (** Splitting a permission on a composite resource into two separate permissions *) val split_action - (#a:Type u#(a + 1)) + (#a:Type) (#pcm:pcm a) (r:ref a pcm) (v0:FStar.Ghost.erased a) @@ -172,7 +171,7 @@ val split_action (** Combining separate permissions into a single composite permission *) val gather_action - (#a:Type u#(a + 1)) + (#a:Type) (#pcm:pcm a) (r:ref a pcm) (v0:FStar.Ghost.erased a) @@ -181,12 +180,12 @@ val gather_action (pts_to r v0 `star` pts_to r v1) (fun _ -> pts_to r (op pcm v0 v1)) -val alloc_action (#a:Type u#(a + 1)) (#pcm:pcm a) (x:a{pcm.refine x}) +val alloc_action (#a:Type) (#pcm:pcm a) (x:a{pcm.refine x}) : pst_action_except (ref a pcm) emp (fun r -> pts_to r x) -val select_refine (#a:Type u#(a + 1)) (#p:pcm a) +val select_refine (#a:Type) (#p:pcm a) (r:ref a p) (x:erased a) (f:(v:a{compatible p x v} @@ -196,14 +195,14 @@ val select_refine (#a:Type u#(a + 1)) (#p:pcm a) (pts_to r x) (fun v -> pts_to r (f v)) -val upd_gen (#a:Type u#(a + 1)) (#p:pcm a) (r:ref a p) (x y:Ghost.erased a) +val upd_gen (#a:Type) (#p:pcm a) (r:ref a p) (x y:Ghost.erased a) (f:FStar.PCM.frame_preserving_upd p x y) : pst_action_except unit (pts_to r x) (fun _ -> pts_to r y) val pts_to_not_null_action - (#a:Type u#(a + 1)) (#pcm:pcm a) + (#a:Type) (#pcm:pcm a) (r:erased (ref a pcm)) (v:Ghost.erased a) : pst_ghost_action_except (squash (not (is_null r))) @@ -214,11 +213,11 @@ val pts_to_not_null_action [@@erasable] val core_ghost_ref : Type0 val core_ghost_ref_null : core_ghost_ref -let ghost_ref (#a:Type u#a) (p:pcm a) : Type0 = core_ghost_ref -val ghost_pts_to (#a:Type u#(a+1)) (#p:pcm a) (r:ghost_ref p) (v:a) : slprop u#a +let ghost_ref (#a:Type u#(a+3)) (p:pcm a) : Type0 = core_ghost_ref +val ghost_pts_to (#a:Type u#(a+3)) (#p:pcm a) (r:ghost_ref p) (v:a) : slprop u#a val ghost_alloc - (#a:Type u#(a + 1)) + (#a:Type) (#pcm:pcm a) (x:erased a{pcm.refine x}) : pst_ghost_action_except @@ -227,7 +226,7 @@ val ghost_alloc (fun r -> ghost_pts_to r x) val ghost_read - (#a:Type u#(a + 1)) + (#a:Type) (#p:pcm a) (r:ghost_ref p) (x:erased a) @@ -271,248 +270,9 @@ val ghost_gather (fun _ -> ghost_pts_to r (op pcm v0 v1)) val ghost_pts_to_not_null_action - (#a:Type u#(a + 1)) (#pcm:pcm a) + (#a:Type) (#pcm:pcm a) (r:ghost_ref pcm) (v:Ghost.erased a) : pst_ghost_action_except (squash (r =!= core_ghost_ref_null)) (ghost_pts_to r v) (fun _ -> ghost_pts_to r v) - -(* Concrete references to "big" types *) -val big_pts_to (#a:Type u#(a + 2)) (#pcm:_) (r:ref a pcm) (v:a) : slprop u#a - -(** Splitting a permission on a composite resource into two separate permissions *) -val big_split_action - (#a:Type u#(a + 2)) - (#pcm:pcm a) - (r:ref a pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a{composable pcm v0 v1}) -: pst_ghost_action_except unit - (big_pts_to r (v0 `op pcm` v1)) - (fun _ -> big_pts_to r v0 `star` big_pts_to r v1) - -(** Combining separate permissions into a single composite permission *) -val big_gather_action - (#a:Type u#(a + 2)) - (#pcm:pcm a) - (r:ref a pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a) -: pst_ghost_action_except (squash (composable pcm v0 v1)) - (big_pts_to r v0 `star` big_pts_to r v1) - (fun _ -> big_pts_to r (op pcm v0 v1)) - -val big_alloc_action - (#a:Type u#(a + 2)) - (#pcm:pcm a) - (x:a{pcm.refine x}) -: pst_action_except (ref a pcm) - emp - (fun r -> big_pts_to r x) - -val big_select_refine - (#a:Type u#(a + 2)) - (#p:pcm a) - (r:ref a p) - (x:erased a) - (f:(v:a{compatible p x v} - -> GTot (y:a{compatible p y v /\ - FStar.PCM.frame_compatible p x v y}))) -: pst_action_except (v:a{compatible p x v /\ p.refine v}) - (big_pts_to r x) - (fun v -> big_pts_to r (f v)) - -val big_upd_gen - (#a:Type u#(a + 2)) - (#p:pcm a) - (r:ref a p) - (x y:Ghost.erased a) - (f:FStar.PCM.frame_preserving_upd p x y) -: pst_action_except unit - (big_pts_to r x) - (fun _ -> big_pts_to r y) - -val big_pts_to_not_null_action - (#a:Type u#(a + 2)) - (#pcm:pcm a) - (r:erased (ref a pcm)) - (v:Ghost.erased a) -: pst_ghost_action_except (squash (not (is_null r))) - (big_pts_to r v) - (fun _ -> big_pts_to r v) - -val big_ghost_pts_to (#a:Type u#(a + 2)) (#p:pcm a) (r:ghost_ref p) (v:a) : slprop u#a - -val big_ghost_alloc - (#a:Type u#(a + 2)) - (#pcm:pcm a) - (x:erased a{pcm.refine x}) -: pst_ghost_action_except - (ghost_ref pcm) - emp - (fun r -> big_ghost_pts_to r x) - -val big_ghost_read - (#a:Type u#(a + 2)) - (#p:pcm a) - (r:ghost_ref p) - (x:erased a) - (f:(v:a{compatible p x v} - -> GTot (y:a{compatible p y v /\ - FStar.PCM.frame_compatible p x v y}))) -: pst_ghost_action_except - (erased (v:a{compatible p x v /\ p.refine v})) - (big_ghost_pts_to r x) - (fun v -> big_ghost_pts_to r (f v)) - -val big_ghost_write - (#a:Type u#(a + 2)) - (#p:pcm a) - (r:ghost_ref p) - (x y:Ghost.erased a) - (f:FStar.PCM.frame_preserving_upd p x y) -: pst_ghost_action_except unit - (big_ghost_pts_to r x) - (fun _ -> big_ghost_pts_to r y) - -val big_ghost_share - (#a:Type u#(a + 2)) - (#pcm:pcm a) - (r:ghost_ref pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a{composable pcm v0 v1}) -: pst_ghost_action_except unit - (big_ghost_pts_to r (v0 `op pcm` v1)) - (fun _ -> big_ghost_pts_to r v0 `star` big_ghost_pts_to r v1) - -val big_ghost_gather - (#a:Type u#(a + 2)) - (#pcm:pcm a) - (r:ghost_ref pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a) -: pst_ghost_action_except - (squash (composable pcm v0 v1)) - (big_ghost_pts_to r v0 `star` big_ghost_pts_to r v1) - (fun _ -> big_ghost_pts_to r (op pcm v0 v1)) - -(* References for objects in universes a+2, "non-boxable" pts_to *) -val nb_pts_to (#a:Type u#(a + 3)) (#pcm:_) (r:ref a pcm) (v:a) : slprop u#a - -(** Splitting a permission on a composite resource into two separate permissions *) -val nb_split_action - (#a:Type u#(a + 3)) - (#pcm:pcm a) - (r:ref a pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a{composable pcm v0 v1}) -: pst_ghost_action_except unit - (nb_pts_to r (v0 `op pcm` v1)) - (fun _ -> nb_pts_to r v0 `star` nb_pts_to r v1) - -(** Combining separate permissions into a single composite permission *) -val nb_gather_action - (#a:Type u#(a + 3)) - (#pcm:pcm a) - (r:ref a pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a) -: pst_ghost_action_except (squash (composable pcm v0 v1)) - (nb_pts_to r v0 `star` nb_pts_to r v1) - (fun _ -> nb_pts_to r (op pcm v0 v1)) - -val nb_alloc_action - (#a:Type u#(a + 3)) - (#pcm:pcm a) - (x:a{pcm.refine x}) -: pst_action_except (ref a pcm) - emp - (fun r -> nb_pts_to r x) - -val nb_select_refine - (#a:Type u#(a + 3)) - (#p:pcm a) - (r:ref a p) - (x:erased a) - (f:(v:a{compatible p x v} - -> GTot (y:a{compatible p y v /\ - FStar.PCM.frame_compatible p x v y}))) -: pst_action_except (v:a{compatible p x v /\ p.refine v}) - (nb_pts_to r x) - (fun v -> nb_pts_to r (f v)) - -val nb_upd_gen - (#a:Type u#(a + 3)) - (#p:pcm a) - (r:ref a p) - (x y:Ghost.erased a) - (f:FStar.PCM.frame_preserving_upd p x y) -: pst_action_except unit - (nb_pts_to r x) - (fun _ -> nb_pts_to r y) - -val nb_pts_to_not_null_action - (#a:Type u#(a + 3)) - (#pcm:pcm a) - (r:erased (ref a pcm)) - (v:Ghost.erased a) -: pst_ghost_action_except (squash (not (is_null r))) - (nb_pts_to r v) - (fun _ -> nb_pts_to r v) - -val nb_ghost_pts_to (#a:Type u#(a + 3)) (#p:pcm a) (r:ghost_ref p) (v:a) : slprop u#a - -val nb_ghost_alloc - (#a:Type u#(a + 3)) - (#pcm:pcm a) - (x:erased a{pcm.refine x}) -: pst_ghost_action_except - (ghost_ref pcm) - emp - (fun r -> nb_ghost_pts_to r x) - -val nb_ghost_read - (#a:Type u#(a + 3)) - (#p:pcm a) - (r:ghost_ref p) - (x:erased a) - (f:(v:a{compatible p x v} - -> GTot (y:a{compatible p y v /\ - FStar.PCM.frame_compatible p x v y}))) -: pst_ghost_action_except - (erased (v:a{compatible p x v /\ p.refine v})) - (nb_ghost_pts_to r x) - (fun v -> nb_ghost_pts_to r (f v)) - -val nb_ghost_write - (#a:Type u#(a + 3)) - (#p:pcm a) - (r:ghost_ref p) - (x y:Ghost.erased a) - (f:FStar.PCM.frame_preserving_upd p x y) -: pst_ghost_action_except unit - (nb_ghost_pts_to r x) - (fun _ -> nb_ghost_pts_to r y) - -val nb_ghost_share - (#a:Type u#(a + 3)) - (#pcm:pcm a) - (r:ghost_ref pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a{composable pcm v0 v1}) -: pst_ghost_action_except unit - (nb_ghost_pts_to r (v0 `op pcm` v1)) - (fun _ -> nb_ghost_pts_to r v0 `star` nb_ghost_pts_to r v1) - -val nb_ghost_gather - (#a:Type u#(a + 3)) - (#pcm:pcm a) - (r:ghost_ref pcm) - (v0:FStar.Ghost.erased a) - (v1:FStar.Ghost.erased a) -: pst_ghost_action_except - (squash (composable pcm v0 v1)) - (nb_ghost_pts_to r v0 `star` nb_ghost_pts_to r v1) - (fun _ -> nb_ghost_pts_to r (op pcm v0 v1)) - diff --git a/lib/pulse/lib/Pulse.Lib.HigherArray.fst b/lib/pulse/lib/Pulse.Lib.Array.Basic.fst similarity index 80% rename from lib/pulse/lib/Pulse.Lib.HigherArray.fst rename to lib/pulse/lib/Pulse.Lib.Array.Basic.fst index 13bca4ff3..464571a65 100644 --- a/lib/pulse/lib/Pulse.Lib.HigherArray.fst +++ b/lib/pulse/lib/Pulse.Lib.Array.Basic.fst @@ -14,7 +14,7 @@ limitations under the License. *) -module Pulse.Lib.HigherArray -include Pulse.Lib.HigherArray.Core -include Pulse.Lib.HigherArray.PtsTo -include Pulse.Lib.HigherArray.PtsToRange \ No newline at end of file +module Pulse.Lib.Array.Basic +include Pulse.Lib.Array.Core +include Pulse.Lib.Array.PtsTo +include Pulse.Lib.Array.PtsToRange \ No newline at end of file diff --git a/lib/pulse/lib/Pulse.Lib.Array.Core.fst b/lib/pulse/lib/Pulse.Lib.Array.Core.fst index 325361059..ab04fc191 100644 --- a/lib/pulse/lib/Pulse.Lib.Array.Core.fst +++ b/lib/pulse/lib/Pulse.Lib.Array.Core.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. @@ -17,123 +17,507 @@ module Pulse.Lib.Array.Core #lang-pulse open Pulse.Main +open FStar.Tactics.V2 open Pulse.Lib.Core -module H = Pulse.Lib.HigherArray open PulseCore.FractionalPermission open FStar.Ghost module SZ = FStar.SizeT module Seq = FStar.Seq +open FStar.PCM +module Frac = Pulse.Lib.PCM.Fraction +module PM = Pulse.Lib.PCM.Map +open Pulse.Lib.PCM.Array +module PA = Pulse.Lib.PCM.Array +open Pulse.Lib.PCMReference + + +/// An abstract type to represent a base array (whole allocation +/// unit), exposed for proof purposes only +[@@erasable] +noeq type base_t : Type0 = { + base_len: base_len:nat { SZ.fits base_len }; + base_ref: base_ref:core_pcm_ref { + base_ref == null_core_pcm_ref ==> base_len == 0 + }; +} -let base_t = H.base_t -inline_for_extraction -let array a = H.array a -let length #a x = H.length x -let base_of x = H.base_of x -let offset_of x = H.offset_of x -let is_full_array #a x = H.is_full_array x +noeq +type array' : Type0 = { + base_len: base_len:Ghost.erased nat { SZ.fits base_len }; + base_ref: base_ref:core_pcm_ref { + base_ref == null_core_pcm_ref ==> base_len == hide 0 + }; + offset: offset: nat { offset <= base_len }; + length: length:Ghost.erased nat {offset + length <= base_len }; +} +let array elt = array' -inline_for_extraction -let null #a : array a = H.null -inline_for_extraction -let is_null r = H.is_null r +let null_array' : array' = { base_len = 0; base_ref = null_core_pcm_ref; offset = 0; length = 0 } -[@@pulse_unfold] -let pts_to_mask #t ([@@@mkey] a: array t) (#[full_default()] f: perm) (v: erased (Seq.seq t)) (mask: nat -> prop) : slprop = - H.pts_to_mask a #f v mask +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 } +let offset_of #t (a: array t) : GTot nat = a.offset -let pts_to_mask_timeless (#a:Type) (x:array a) (p:perm) (s:Seq.seq a) mask = - () +let is_full_array (#elt: Type) (a: array elt) : Tot prop = + length a == reveal a.base_len -let pts_to_mask_len a = H.pts_to_mask_len a -let pts_to_mask_not_null r = H.pts_to_mask_not_null r +let null #a : array a = null_array' +let is_null a = is_null_core_pcm_ref a.base_ref -let mask_vext arr = H.mask_vext arr -let mask_mext arr = H.mask_mext arr -let mask_ext arr = H.mask_ext arr +let lptr_of #elt (a: array elt) : pcm_ref (PA.pcm elt a.base_len) = + a.base_ref -let mask_share arr = H.mask_share arr -let mask_gather arr = H.mask_gather arr +[@@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 -> + if off <= i && i < off + Seq.length v && mask (i - off) then + Some (Seq.index v (i - off), f) + else + None -let split_mask arr = H.split_mask arr -let join_mask arr = H.join_mask arr -let join_mask' arr = H.join_mask' arr +[@@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 pts_to_mask_injective_eq arr = H.pts_to_mask_injective_eq arr +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 -inline_for_extraction let mask_read a = H.mask_read a -inline_for_extraction let mask_write a = H.mask_write a +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 gsub arr = H.gsub arr +let mask_nonempty (mask: nat -> prop) (len: nat) : prop = + exists i. mask i /\ i < len -let gsub_intro arr = H.gsub_intro arr -let gsub_elim arr = H.gsub_elim arr +// workaround for https://github.com/FStarLang/pulse/issues/430 +let squash' (t: Type u#a) = squash t +let intro_squash #t (x: t) : squash' t = () -inline_for_extraction let sub arr = H.sub arr -let return_sub arr = H.return_sub arr +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) ** + pure (Seq.length v == reveal a.length /\ (mask_nonempty mask a.length ==> f <=. 1.0R) /\ squash' t) + +let pts_to_mask_timeless _ _ _ _ = () + +ghost +fn pts_to_mask_props u#a (#t: Type u#a) (a:array t) (#p:perm) (#x:Seq.seq t) #mask + preserves pts_to_mask a #p x mask + ensures pure (length a == Seq.length x) + ensures pure (mask_nonempty mask (length a) ==> p <=. 1.0R) + ensures pure (~(is_null a)) + ensures pure (squash' t) +{ + unfold pts_to_mask a #p x mask; + pts_to_not_null (lptr_of a) _; + fold pts_to_mask a #p x mask; +} -let pts_to r = H.pts_to r +ghost +fn pts_to_mask_len u#a (#t: Type u#a) (a:array t) (#p:perm) (#x:Seq.seq t) #mask + preserves pts_to_mask a #p x mask + ensures pure (length a == Seq.length x) +{ + pts_to_mask_props a; +} -let to_mask arr = H.to_mask arr -let from_mask arr = H.from_mask arr +ghost +fn pts_to_mask_perm_bound u#a (#t: Type u#a) (arr: array t) #p (#s:Seq.seq t) #mask + preserves pts_to_mask arr #p s mask + requires pure (exists (i: nat). i < Seq.length s /\ mask i) + ensures pure (p <=. 1.0R) +{ + pts_to_mask_props arr; +} -let pts_to_timeless _ _ _ = () -let pts_to_len a = H.pts_to_len a +ghost +fn pts_to_mask_not_null u#a (#a: Type u#a) #p (r:array a) (#v:Seq.seq a) #mask + preserves pts_to_mask r #p v mask + ensures pure (not (is_null r)) +{ + pts_to_mask_props r; +} -inline_for_extraction let alloc x = H.alloc x +ghost fn mask_vext u#a (#t: Type u#a) (arr: array t) #f #v v' #mask + requires pts_to_mask arr #f v mask + requires pure (Seq.length v' == Seq.length v /\ + (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 +{ + unfold pts_to_mask arr #f v mask; + assert pure (mk_carrier' arr f v mask `Map.equal` mk_carrier' arr f v' mask); + fold pts_to_mask arr #f v' mask; +} -inline_for_extraction let op_Array_Access a = H.op_Array_Access a -inline_for_extraction let op_Array_Assignment a = H.op_Array_Assignment a +ghost fn mask_mext u#a (#t: Type u#a) (arr: array t) #f #v #mask (mask': nat -> prop) + requires pts_to_mask arr #f v mask + requires pure (forall (i: nat). i < Seq.length v ==> (mask i <==> mask' i)) + 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'); + fold pts_to_mask arr #f v mask'; +} -inline_for_extraction let free a = H.free a +ghost fn mask_ext u#a (#t: Type u#a) (arr: array t) #f #v #mask v' (mask': nat -> prop) + requires pts_to_mask arr #f v mask + requires pure (forall (i: nat). i < Seq.length v ==> (mask i <==> mask' i)) + requires pure (Seq.length v' == Seq.length v /\ + (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' +{ + mask_vext arr v'; + mask_mext arr mask'; +} -let share arr = H.share arr -let gather arr = H.gather arr +[@@noextract_to "krml"] +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) +{ + 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; + pts_to_not_null b _; + let arr: array elt = { base_ref = b; base_len = SZ.v n; length = SZ.v n; offset = 0 }; + 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)); + intro_squash x; + fold pts_to_mask arr (Seq.create (SZ.v n) x) (fun _ -> l_True); + arr +} -let pts_to_range x = H.pts_to_range x +[@@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 + requires pure (forall i. mask i) + requires pure (is_full_array a) +{ + drop_ (pts_to_mask a s mask); +} -let pts_to_range_timeless _ _ _ _ _ = () +let get_mask_idx (m: nat->prop) (l: nat) : GTot (i: nat { mask_nonempty m l ==> i < l /\ m i }) = + if IndefiniteDescription.strong_excluded_middle (mask_nonempty m l) then + IndefiniteDescription.indefinite_description_ghost nat fun i -> i < l /\ m i + else + 0 + +ghost fn pcm_rw u#a (#t: Type u#a) + (a1: array t) p1 s1 m1 + (a2: array t) p2 s2 m2 + requires pts_to_mask #t a1 #p1 s1 m1 + requires pure ( + a1.base_len == a2.base_len /\ + a1.base_ref == a2.base_ref /\ + reveal a2.length == Seq.length s2 /\ + mk_carrier' a1 p1 s1 m1 `Map.equal` mk_carrier' a2 p2 s2 m2 + ) + ensures pts_to_mask #t a2 #p2 s2 m2 +{ + unfold pts_to_mask a1 #p1 s1 m1; + 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)); + fold pts_to_mask a2 #p2 s2 m2; +} -let pts_to_range_prop a = H.pts_to_range_prop a +ghost fn pcm_share u#a (#t: Type u#a) + (a: array t) p s m + (a1: array t) p1 s1 m1 + (a2: array t) p2 s2 m2 + 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 + ) + 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); + 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); + 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); + 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))); + 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))); + fold pts_to_mask a2 #p2 s2 m2; +} -let pts_to_range_intro a = H.pts_to_range_intro a -let pts_to_range_elim a = H.pts_to_range_elim a +ghost fn pcm_gather u#a (#t: Type u#a) + (a: array t) p s m + (a1: array t) p1 s1 m1 + (a2: array t) p2 s2 m2 + 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) + ) + requires pts_to_mask a1 #p1 s1 m1 + requires pts_to_mask a2 #p2 s2 m2 + ensures pts_to_mask a #p s m + 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 + ) +{ + unfold pts_to_mask a1 #p1 s1 m1; + unfold pts_to_mask a2 #p2 s2 m2; + 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); + 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); + 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)); + fold pts_to_mask a #p s m; +} -let pts_to_range_split a = H.pts_to_range_split a -let pts_to_range_join a = H.pts_to_range_join a +ghost +fn mask_share u#a (#a: Type u#a) (arr:array a) (#s: Seq.seq a) #p #mask + requires pts_to_mask arr #p s mask + ensures pts_to_mask arr #(p /. 2.0R) s mask + ensures pts_to_mask arr #(p /. 2.0R) s mask +{ + pts_to_mask_props arr; + pcm_share + arr p s mask + arr (p /. 2.0R) s mask + arr (p /. 2.0R) s mask; +} -inline_for_extraction let pts_to_range_index a = H.pts_to_range_index a -inline_for_extraction let pts_to_range_upd a = H.pts_to_range_upd a +[@@allow_ambiguous] +ghost fn mask_gather u#a (#t: Type u#a) (arr: array t) #p1 #p2 #s1 #s2 #mask1 #mask2 + requires pts_to_mask arr #p1 s1 mask1 + requires pts_to_mask arr #p2 s2 mask2 + requires pure (forall i. mask1 i <==> mask2 i) + ensures exists* (v: Seq.seq t). pts_to_mask arr #(p1 +. p2) v mask1 ** + 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)) +{ + mask_mext arr #p2 #s2 mask1; + pts_to_mask_props arr #p1 #s1 #mask1; + pts_to_mask_props arr #p2 #s2 #mask1; + pcm_gather + arr (p1 +. p2) s1 mask1 + 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)); +} + +ghost fn split_mask u#a (#t: Type u#a) (arr: array t) #f #v #mask (pred: nat -> prop) + requires pts_to_mask arr #f v mask + ensures pts_to_mask arr #f v (mask_isect mask pred) + ensures pts_to_mask arr #f v (mask_diff mask pred) +{ + 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); +} + +let mix #t (v1: Seq.seq t) (v2: Seq.seq t { Seq.length v1 == Seq.length v2 }) (mask: nat -> prop) : + GTot (res: Seq.seq t { Seq.length res == Seq.length v1 /\ + (forall (i: nat). i < Seq.length res ==> + (mask i ==> Seq.index res i == Seq.index v1 i) /\ + (~(mask i) ==> Seq.index res i == Seq.index v2 i)) }) = + Seq.init_ghost (Seq.length v1) fun i -> + if IndefiniteDescription.strong_excluded_middle (mask i) then Seq.index v1 i else Seq.index v2 i + +[@@allow_ambiguous] +ghost fn join_mask u#a (#t: Type u#a) (arr: array t) #f #v1 #v2 #mask1 #mask2 + requires pts_to_mask arr #f v1 mask1 + requires pts_to_mask arr #f v2 mask2 + requires pure (forall i. ~(mask1 i /\ mask2 i)) + ensures exists* (v: Seq.seq t). + pts_to_mask arr #f v (fun i -> mask1 i \/ mask2 i) ** + pure (Seq.length v == Seq.length v1 /\ Seq.length v == Seq.length v2 /\ + (forall (i: nat). i < Seq.length v ==> + (mask1 i ==> Seq.index v i == Seq.index v1 i) /\ + (mask2 i ==> Seq.index v i == Seq.index v2 i))) +{ + pts_to_mask_props arr #f #v1 #mask1; + pts_to_mask_props arr #f #v2 #mask2; + let v = mix v1 v2 mask1; + with mask. assert pure (mask == (fun i -> mask1 i \/ mask2 i)); + pcm_gather + arr f v mask + arr f v1 mask1 + arr f v2 mask2; +} + +[@@allow_ambiguous] +ghost fn join_mask' u#a (#t: Type u#a) (arr: array t) #f (#v: erased (Seq.seq t)) #mask1 #mask2 + requires pts_to_mask arr #f v mask1 + requires pts_to_mask arr #f v mask2 + requires pure (forall i. ~(mask1 i /\ mask2 i)) + ensures pts_to_mask arr #f v (fun i -> mask1 i \/ mask2 i) +{ + join_mask arr #f #v #v #mask1 #mask2; + mask_vext arr v; +} + +[@@allow_ambiguous] +ghost +fn pts_to_mask_injective_eq u#a (#a: Type u#a) #p0 #p1 #s0 #s1 #mask0 #mask1 (arr:array a) + preserves pts_to_mask arr #p0 s0 mask0 + preserves pts_to_mask arr #p1 s1 mask1 + ensures pure (Seq.length s0 == Seq.length s1 /\ + (forall (i: nat). i < Seq.length s0 /\ mask0 i /\ mask1 i ==> + Seq.index s0 i == Seq.index s1 i)) +{ + unfold pts_to_mask arr #p0 s0 mask0; + 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); + 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)); + fold pts_to_mask arr #p0 s0 mask0; + fold pts_to_mask arr #p1 s1 mask1; +} + +[@@noextract_to "krml"] +fn mask_read u#a (#t: Type u#a) (a: array t) (i: SZ.t) #p (#s: erased (Seq.seq t) { SZ.v i < Seq.length s }) #mask + preserves pts_to_mask a #p s mask + requires pure (mask (SZ.v i)) + returns res: t + ensures pure (res == Seq.index s (SZ.v i)) +{ + unfold pts_to_mask a #p s mask; + 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))); +} + +[@@noextract_to "krml"] +fn mask_write u#a (#t: Type u#a) (a: array t) (i: SZ.t) (v: t) (#s: erased (Seq.seq t) { SZ.v i < Seq.length s }) #mask + requires pts_to_mask a s mask + requires pure (mask (SZ.v i)) + ensures pts_to_mask a (Seq.upd s (SZ.v i) v) mask +{ + unfold pts_to_mask a s mask; + 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 + ) + _ (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.equal` + mk_carrier' a 1.0R (Seq.upd s (SZ.v i) v) mask + ); + fold pts_to_mask a (Seq.upd s (SZ.v i) v) mask; +} -let pts_to_range_share arr = H.pts_to_range_share arr -let pts_to_range_gather arr = H.pts_to_range_gather arr +[@@noextract_to "krml"] +let sub_impl #t (arr: array t) (i: nat) (j: erased nat { i <= j /\ j <= length arr }) : array t = + { arr with offset = arr.offset + i; length = j - i } -let with_pre (pre:slprop) (#a:Type) (#post:a -> slprop)(m:stt a emp post) -: stt a pre (fun v -> pre ** post v) -= let m1 = frame_stt pre m in - let pf_post : slprop_post_equiv (fun r -> post r ** pre) (fun r -> pre ** post r) - = intro_slprop_post_equiv _ _ (fun r -> slprop_equiv_comm (post r) pre) - in - sub_stt _ _ (slprop_equiv_unit pre) pf_post m1 +let gsub #t (arr: array t) (i: nat) (j: nat { i <= j /\ j <= length arr }) : GTot (array t) = + sub_impl arr i j +let length_gsub #t arr i j = () +let offset_of_gsub #t arr i j = () +let base_of_gsub #t arr i j = () -fn with_local u#a - (#a:Type0) - (init:a) - (len:SZ.t) - (#pre:slprop) - (ret_t:Type u#a) - (#post:ret_t -> slprop) - (body:(arr:array a) -> stt ret_t (pre ** - (pts_to arr (Seq.create (SZ.v len) init) ** - (pure (is_full_array arr) ** - pure (length arr == SZ.v len)))) - (fun r -> post r ** (exists* v. pts_to arr v))) - requires pre - returns r: ret_t - ensures post r +ghost fn gsub_intro u#a (#t: Type u#a) (arr: array t) #f #mask (i j: nat) (#v: erased (Seq.seq t) { i <= j /\ j <= Seq.length v }) + requires pts_to_mask arr #f v mask + requires pure (forall (k: nat). mask k /\ k < Seq.length v ==> i <= k /\ k < j) + returns _: squash (length arr == Seq.length v) + ensures pts_to_mask (gsub arr i j) #f (Seq.slice v i j) (fun k -> mask (k + i)) { - let arr = alloc init len; - let r = body arr; - free arr; - r + pts_to_mask_props arr; + pcm_rw + arr f v mask + (gsub arr i j) f (Seq.slice v i j) (fun k -> mask (k + i)); + () } + +let elim_squash (t: Type u#a { squash' t }) : GTot t = + let h : squash (squash' t) = () in + let h : squash t = IndefiniteDescription.elim_squash h in + IndefiniteDescription.elim_squash h + +ghost fn gsub_elim u#a (#t: Type u#a) (arr: array t) #f (#mask: nat->prop) (i j: nat) + (#v: erased (Seq.seq t) { i <= j /\ j <= length arr }) + requires pts_to_mask (gsub arr i j) #f v mask + returns _: squash (j - i == Seq.length v) + ensures exists* (v': Seq.seq t). + pts_to_mask arr #f v' (fun k -> i <= k /\ k < j /\ mask (k - i)) ** + pure (Seq.length v' == length arr /\ (forall (k:nat). k < j - i ==> Seq.index v k == Seq.index v' (k + i))) +{ + pts_to_mask_props (gsub arr i j); + let dummy = elim_squash t; + let v' = Seq.init_ghost (length arr) (fun k -> + if i <= k && k < j then Seq.index v (k - i) else dummy); + pcm_rw + (gsub arr i j) f v mask + arr f v' (fun k -> i <= k /\ k < j /\ mask (k - i)); + () +} + +[@@noextract_to "krml"] +unobservable +fn sub u#a (#t: Type u#a) (arr: array t) #f #mask (i: SZ.t) (j: erased nat) + (#v: erased (Seq.seq t) { SZ.v i <= j /\ j <= Seq.length (reveal v) }) + requires pts_to_mask arr #f v mask + returns sub: (sub: array t { length arr == Seq.length (reveal v) }) + ensures rewrites_to sub (gsub arr (SZ.v i) j) + ensures pts_to_mask sub #f (Seq.slice v (SZ.v i) j) (fun k -> mask (k + SZ.v i)) + ensures pts_to_mask arr #f v (fun k -> mask k /\ ~(SZ.v i <= k /\ k < j)) +{ + let pred = (fun k -> SZ.v i <= k /\ k < j); + pts_to_mask_props arr; + split_mask arr pred; + gsub_intro arr #f #(mask_isect mask pred) (SZ.v i) j; + mask_mext (gsub arr (SZ.v i) j) (fun k -> mask (k + SZ.v i)); + rewrite each gsub arr (SZ.v i) j as sub_impl arr (SZ.v i) j; + sub_impl arr (SZ.v i) j +} + +[@@allow_ambiguous] +ghost fn return_sub u#a (#t: Type u#a) (arr: array t) #f (#v #vsub: erased (Seq.seq t)) #mask #masksub (#i: nat) (#j: nat { i <= j /\ j <= length arr }) + requires pts_to_mask arr #f v mask + requires pts_to_mask (gsub arr i j) #f vsub masksub + requires pure (forall (k: nat). i <= k /\ k < j ==> ~(mask k)) + ensures exists* v'. pts_to_mask arr #f v' (fun k -> mask k \/ (i <= k /\ k < j /\ masksub (k - i))) + ** pure (Seq.length v == Seq.length v' /\ i + Seq.length vsub == j /\ j <= Seq.length v /\ + (forall (k: nat). k < Seq.length v' ==> + Seq.index v' k == (if i <= k && k < j then Seq.index vsub (k - i) else Seq.index v k))) +{ + gsub_elim arr i j; + join_mask arr; + let v' = Seq.init_ghost (Seq.length v) (fun k -> + if i <= k && k < j then Seq.index vsub (k - i) else Seq.index v k); + mask_ext arr v' (fun k -> mask k \/ (i <= k /\ k < j /\ masksub (k - i))); +} \ No newline at end of file diff --git a/lib/pulse/lib/Pulse.Lib.Array.Core.fsti b/lib/pulse/lib/Pulse.Lib.Array.Core.fsti index bc51a9d43..b06e81f05 100644 --- a/lib/pulse/lib/Pulse.Lib.Array.Core.fsti +++ b/lib/pulse/lib/Pulse.Lib.Array.Core.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. @@ -23,14 +23,13 @@ open Pulse.Class.PtsTo open PulseCore.FractionalPermission open FStar.Ghost module SZ = FStar.SizeT -module Seq = FStar.Seq +open Pulse.Lib.SmallType [@@erasable] val base_t : Type0 -inline_for_extraction -val array ([@@@strictly_positive] a:Type u#0) : Type u#0 +val array ([@@@unused] a:Type u#a) : Type u#0 -val length (#a:Type u#0) (x:array a) : Ghost nat (requires True) (ensures SZ.fits) +val length (#a:Type) (x:array a) : Ghost nat (requires True) (ensures SZ.fits) val base_of #t (a: array t) : base_t val offset_of #t (a: array t) : GTot nat @@ -39,55 +38,69 @@ type elseq (a:Type) (l:SZ.t) = s:erased (Seq.seq a) { Seq.length s == SZ.v l } inline_for_extraction type larray t (n:nat) = a:array t { length a == n } -val is_full_array (#a:Type u#0) (x:array a) : prop +val is_full_array (#a:Type) (x:array a) : prop -inline_for_extraction val null #a : array a -inline_for_extraction val is_null #a (r: array a) : b:bool {b <==> r == null #a} -val pts_to_mask #t ([@@@mkey] a: array t) (#[full_default()] f: perm) (v: erased (Seq.seq t)) (mask: nat -> prop) : slprop +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 pts_to_mask_timeless (#a:Type) (x:array a) (p:perm) (s:Seq.seq a) mask +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))] ghost -fn pts_to_mask_len #t (a:array t) (#p:perm) (#x:Seq.seq t) #mask +fn pts_to_mask_len u#a (#t: Type u#a) (a:array t) (#p:perm) (#x:Seq.seq t) #mask preserves pts_to_mask a #p x mask ensures pure (length a == Seq.length x) ghost -fn pts_to_mask_not_null #a #p (r:array a) (#v:Seq.seq a) #mask +fn pts_to_mask_perm_bound u#a (#t: Type u#a) (arr: array t) #p (#s:Seq.seq t) #mask + preserves pts_to_mask arr #p s mask + requires pure (exists (i: nat). i < Seq.length s /\ mask i) + ensures pure (p <=. 1.0R) + +ghost +fn pts_to_mask_not_null u#a (#a: Type u#a) #p (r:array a) (#v:Seq.seq a) #mask preserves pts_to_mask r #p v mask ensures pure (not (is_null r)) -ghost fn mask_vext #t (arr: array t) #f #v v' #mask +ghost fn mask_vext u#a (#t: Type u#a) (arr: array t) #f #v v' #mask requires pts_to_mask arr #f v mask requires pure (Seq.length v' == Seq.length v /\ (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 -ghost fn mask_mext #t (arr: array t) #f #v #mask (mask': nat -> prop) +ghost fn mask_mext u#a (#t: Type u#a) (arr: array t) #f #v #mask (mask': nat -> prop) requires pts_to_mask arr #f v mask requires pure (forall (i: nat). i < Seq.length v ==> (mask i <==> mask' i)) ensures pts_to_mask arr #f v mask' -ghost fn mask_ext #t (arr: array t) #f #v #mask v' (mask': nat -> prop) +ghost fn mask_ext u#a (#t: Type u#a) (arr: array t) #f #v #mask v' (mask': nat -> prop) requires pts_to_mask arr #f v mask requires pure (forall (i: nat). i < Seq.length v ==> (mask i <==> mask' i)) requires pure (Seq.length v' == Seq.length v /\ (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' +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) + +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) + requires pure (is_full_array a) + ghost -fn mask_share #a (arr:array a) (#s: Seq.seq a) #p #mask +fn mask_share u#a (#a: Type u#a) (arr:array a) (#s: Seq.seq a) #p #mask requires pts_to_mask arr #p s mask ensures pts_to_mask arr #(p /. 2.0R) s mask ensures pts_to_mask arr #(p /. 2.0R) s mask [@@allow_ambiguous] -ghost fn mask_gather #t (arr: array t) #p1 #p2 #s1 #s2 #mask1 #mask2 +ghost fn mask_gather u#a (#t: Type u#a) (arr: array t) #p1 #p2 #s1 #s2 #mask1 #mask2 requires pts_to_mask arr #p1 s1 mask1 requires pts_to_mask arr #p2 s2 mask2 requires pure (forall i. mask1 i <==> mask2 i) @@ -97,15 +110,16 @@ ghost fn mask_gather #t (arr: array t) #p1 #p2 #s1 #s2 #mask1 #mask2 // We need to give names to these combinators, otherwise unfold can't // distinguish them when we have multiple pts_to_mask resources. -include Pulse.Lib.HigherArray {mask_isect, mask_diff} +unfold let mask_isect (mask pred: nat -> prop) : nat -> prop = fun i -> mask i /\ pred i +unfold let mask_diff (mask pred: nat -> prop) : nat -> prop = fun i -> mask i /\ ~(pred i) -ghost fn split_mask #t (arr: array t) #f #v #mask (pred: nat -> prop) +ghost fn split_mask u#a (#t: Type u#a) (arr: array t) #f #v #mask (pred: nat -> prop) requires pts_to_mask arr #f v mask ensures pts_to_mask arr #f v (mask_isect mask pred) ensures pts_to_mask arr #f v (mask_diff mask pred) [@@allow_ambiguous] -ghost fn join_mask #t (arr: array t) #f #v1 #v2 #mask1 #mask2 +ghost fn join_mask u#a (#t: Type u#a) (arr: array t) #f #v1 #v2 #mask1 #mask2 requires pts_to_mask arr #f v1 mask1 requires pts_to_mask arr #f v2 mask2 requires pure (forall i. ~(mask1 i /\ mask2 i)) @@ -117,7 +131,7 @@ ghost fn join_mask #t (arr: array t) #f #v1 #v2 #mask1 #mask2 (mask2 i ==> Seq.index v i == Seq.index v2 i))) [@@allow_ambiguous] -ghost fn join_mask' #t (arr: array t) #f (#v: erased (Seq.seq t)) #mask1 #mask2 +ghost fn join_mask' u#a (#t: Type u#a) (arr: array t) #f (#v: erased (Seq.seq t)) #mask1 #mask2 requires pts_to_mask arr #f v mask1 requires pts_to_mask arr #f v mask2 requires pure (forall i. ~(mask1 i /\ mask2 i)) @@ -125,35 +139,37 @@ ghost fn join_mask' #t (arr: array t) #f (#v: erased (Seq.seq t)) #mask1 #mask2 [@@allow_ambiguous] ghost -fn pts_to_mask_injective_eq #a #p0 #p1 #s0 #s1 #mask0 #mask1 (arr:array a) +fn pts_to_mask_injective_eq u#a (#a: Type u#a) #p0 #p1 #s0 #s1 #mask0 #mask1 (arr:array a) preserves pts_to_mask arr #p0 s0 mask0 preserves pts_to_mask arr #p1 s1 mask1 ensures pure (Seq.length s0 == Seq.length s1 /\ (forall (i: nat). i < Seq.length s0 /\ mask0 i /\ mask1 i ==> Seq.index s0 i == Seq.index s1 i)) -inline_for_extraction -fn mask_read #t (a: array t) (i: SZ.t) #p (#s: erased (Seq.seq t) { SZ.v i < Seq.length s }) #mask +fn mask_read u#a (#t: Type u#a) (a: array t) (i: SZ.t) #p (#s: erased (Seq.seq t) { SZ.v i < Seq.length s }) #mask preserves pts_to_mask a #p s mask requires pure (mask (SZ.v i)) returns res: t ensures pure (res == Seq.index s (SZ.v i)) -inline_for_extraction -fn mask_write #t (a: array t) (i: SZ.t) (v: t) (#s: erased (Seq.seq t) { SZ.v i < Seq.length s }) #mask +fn mask_write u#a (#t: Type u#a) (a: array t) (i: SZ.t) (v: t) (#s: erased (Seq.seq t) { SZ.v i < Seq.length s }) #mask requires pts_to_mask a s mask requires pure (mask (SZ.v i)) ensures pts_to_mask a (Seq.upd s (SZ.v i) v) mask val gsub #t (arr: array t) (i: nat) (j: nat { i <= j /\ j <= length arr }) : GTot (array t) -ghost fn gsub_intro #t (arr: array t) #f #mask (i j: nat) (#v: erased (Seq.seq t) { i <= j /\ j <= Seq.length v }) +val length_gsub #t arr i j : Lemma (length (gsub #t arr i j) == j - i) [SMTPat (length (gsub arr i j))] +val offset_of_gsub #t arr i j : Lemma (offset_of (gsub #t arr i j) == offset_of arr + i) [SMTPat (offset_of (gsub arr i j))] +val base_of_gsub #t arr i j : Lemma (base_of (gsub #t arr i j) == base_of arr) [SMTPat (base_of (gsub arr i j))] + +ghost fn gsub_intro u#a (#t: Type u#a) (arr: array t) #f #mask (i j: nat) (#v: erased (Seq.seq t) { i <= j /\ j <= Seq.length v }) requires pts_to_mask arr #f v mask requires pure (forall (k: nat). mask k /\ k < Seq.length v ==> i <= k /\ k < j) returns _: squash (length arr == Seq.length v) ensures pts_to_mask (gsub arr i j) #f (Seq.slice v i j) (fun k -> mask (k + i)) -ghost fn gsub_elim #t (arr: array t) #f (#mask: nat->prop) (i j: nat) +ghost fn gsub_elim u#a (#t: Type u#a) (arr: array t) #f (#mask: nat->prop) (i j: nat) (#v: erased (Seq.seq t) { i <= j /\ j <= length arr }) requires pts_to_mask (gsub arr i j) #f v mask returns _: squash (j - i == Seq.length v) @@ -161,9 +177,8 @@ ghost fn gsub_elim #t (arr: array t) #f (#mask: nat->prop) (i j: nat) pts_to_mask arr #f v' (fun k -> i <= k /\ k < j /\ mask (k - i)) ** pure (Seq.length v' == length arr /\ (forall (k:nat). k < j - i ==> Seq.index v k == Seq.index v' (k + i))) -inline_for_extraction unobservable -fn sub #t (arr: array t) #f #mask (i: SZ.t) (j: erased nat) +fn sub u#a (#t: Type u#a) (arr: array t) #f #mask (i: SZ.t) (j: erased nat) (#v: erased (Seq.seq t) { SZ.v i <= j /\ j <= Seq.length (reveal v) }) requires pts_to_mask arr #f v mask returns sub: (sub: array t { length arr == Seq.length (reveal v) }) @@ -172,240 +187,11 @@ fn sub #t (arr: array t) #f #mask (i: SZ.t) (j: erased nat) ensures pts_to_mask arr #f v (fun k -> mask k /\ ~(SZ.v i <= k /\ k < j)) [@@allow_ambiguous] -ghost fn return_sub #t (arr: array t) #f (#v #vsub: erased (Seq.seq t)) #mask #masksub (#i: nat) (#j: nat { i <= j /\ j <= length arr }) +ghost fn return_sub u#a (#t: Type u#a) (arr: array t) #f (#v #vsub: erased (Seq.seq t)) #mask #masksub (#i: nat) (#j: nat { i <= j /\ j <= length arr }) requires pts_to_mask arr #f v mask requires pts_to_mask (gsub arr i j) #f vsub masksub requires pure (forall (k: nat). i <= k /\ k < j ==> ~(mask k)) ensures exists* v'. pts_to_mask arr #f v' (fun k -> mask k \/ (i <= k /\ k < j /\ masksub (k - i))) ** pure (Seq.length v == Seq.length v' /\ i + Seq.length vsub == j /\ j <= Seq.length v /\ (forall (k: nat). k < Seq.length v' ==> - Seq.index v' k == (if i <= k && k < j then Seq.index vsub (k - i) else Seq.index v k))) - -val pts_to (#a:Type u#0) ([@@@mkey]x:array a) (#[exact (`1.0R)] p:perm) (s: Seq.seq a) : slprop - -[@@pulse_unfold] -instance has_pts_to_array (a:Type u#0) : has_pts_to (array a) (Seq.seq a) = { - pts_to = pts_to; -} -[@@pulse_unfold] -instance has_pts_to_larray (a:Type u#0) (n : nat) : has_pts_to (larray a n) (Seq.seq a) = { - pts_to = pts_to; -} - -ghost fn to_mask #t (arr: array t) #f (#v: erased _) - requires arr |-> Frac f v - ensures pts_to_mask arr #f v (fun _ -> True) - -ghost fn from_mask #t (arr: array t) #f #v #mask - requires pts_to_mask arr #f v mask - requires pure (forall (i: nat). i < Seq.length v ==> mask i) - ensures arr |-> Frac f v - -val pts_to_timeless (#a:Type) (x:array a) (p:perm) (s:Seq.seq a) - : Lemma (timeless (pts_to x #p s)) - [SMTPat (timeless (pts_to x #p s))] - -ghost -fn pts_to_len (#t:Type0) (a:array t) (#p:perm) (#x:Seq.seq t) - requires pts_to a #p x - ensures pts_to a #p x ** pure (length a == Seq.length x) - -[@@deprecated "Array.Core.alloc is meant to be generated by the Pulse elaborator, not called directly; use Vec.alloc instead"] -inline_for_extraction -fn alloc (#elt: Type) (x: elt) (n: SZ.t) - requires emp - returns a : array elt - ensures pts_to a (Seq.create (SZ.v n) x) ** - pure (length a == SZ.v n /\ is_full_array a) - -(* Written x.(i) *) -inline_for_extraction -fn op_Array_Access - (#t: Type) (a: array t) (i: SZ.t) - (#p: perm) (#s: erased (Seq.seq t){SZ.v i < Seq.length s}) - preserves pts_to a #p s - returns res : t - ensures rewrites_to res (Seq.index s (SZ.v i)) - -(* Written a.(i) <- v *) -inline_for_extraction -fn op_Array_Assignment - (#t: Type) - (a: array t) - (i: SZ.t) - (v: t) - (#s: erased (Seq.seq t) {SZ.v i < Seq.length s}) - requires pts_to a s - ensures pts_to a (Seq.upd s (SZ.v i) v) - -[@@deprecated "Array.Core.free is not meant to be called directly; use Vec.free instead"] -inline_for_extraction -fn free (#elt: Type) (a: array elt) (#s: erased (Seq.seq elt)) - requires pts_to a s ** pure (is_full_array a) - ensures emp - -ghost -fn share - (#a:Type) - (arr:array a) - (#s:erased (Seq.seq a)) - (#p:perm) - requires pts_to arr #p s - ensures pts_to arr #(p /. 2.0R) s ** pts_to arr #(p /. 2.0R) s - -[@@allow_ambiguous] -ghost -fn gather - (#a:Type) - (arr:array a) - (#s0 #s1:erased (Seq.seq a)) - (#p0 #p1:perm) - requires pts_to arr #p0 s0 ** pts_to arr #p1 s1 - ensures pts_to arr #(p0 +. p1) s0 ** pure (s0 == s1) - -val pts_to_range - (#a:Type u#0) - ([@@@mkey] x:array a) - ([@@@mkey] i : nat) - (j : nat) - (* ^NOTE: only using the start as matching key. *) - (#[exact (`1.0R)] p:perm) - (s: Seq.seq a) : slprop - -val pts_to_range_timeless (#a:Type) (x:array a) (i j : nat) (p:perm) (s:Seq.seq a) - : Lemma (timeless (pts_to_range x i j #p s)) - [SMTPat (timeless (pts_to_range x i j #p s))] - -let is_subarray #elt (a: array elt) (i j: nat) (b: array elt) : prop = - base_of b == base_of a /\ - offset_of b == offset_of a + i /\ - i + length b == j /\ - j <= length a - -ghost -fn pts_to_range_prop - (#elt: Type0) (a: array elt) (#i #j: nat) - (#p: perm) - (#s: Seq.seq elt) - requires pts_to_range a i j #p s - ensures pts_to_range a i j #p s - ** pure ( (i <= j /\ j <= length a /\ Seq.length s == j - i)) - -ghost -fn pts_to_range_intro - (#elt: Type0) (a: array elt) - (p: perm) - (s: Seq.seq elt) - requires pts_to a #p s - ensures pts_to_range a 0 (length a) #p s - -ghost -fn pts_to_range_elim - (#elt: Type0) (a: array elt) - (p: perm) - (s: Seq.seq elt) - requires pts_to_range a 0 (length a) #p s - ensures pts_to a #p s - -ghost -fn pts_to_range_split - (#elt: Type0) - (a: array elt) - (i m j: nat) - (#p: perm) - (#s: Seq.seq elt) - requires pts_to_range a i j #p s ** pure (i <= m /\ m <= j) - ensures - exists* s1 s2. - pts_to_range a i m #p s1 ** - pts_to_range a m j #p s2 ** - pure ( - i <= m /\ m <= j /\ j <= length a /\ - eq2 #int (Seq.length s) (j - i) /\ - s1 == Seq.slice s 0 (m - i) /\ - s2 == Seq.slice s (m - i) (Seq.length s) /\ - s == Seq.append s1 s2 - ) - -ghost -fn pts_to_range_join - (#elt: Type0) - (a: array elt) - (i m j: nat) - (#p: perm) - (#s1 #s2: Seq.seq elt) - requires pts_to_range a i m #p s1 ** pts_to_range a m j #p s2 - ensures pts_to_range a i j #p (s1 `Seq.append` s2) - -inline_for_extraction -fn pts_to_range_index - (#t: Type) - (a: array t) - (i: SZ.t) - (#l: erased nat{l <= SZ.v i}) - (#r: erased nat{SZ.v i < r}) - (#s: erased (Seq.seq t)) - (#p: perm) - requires pts_to_range a l r #p s - returns res : t - ensures pts_to_range a l r #p s ** - pure (eq2 #int (Seq.length s) (r - l) /\ - res == Seq.index s (SZ.v i - l)) - -inline_for_extraction -fn pts_to_range_upd - (#t: Type) - (a: array t) - (i: SZ.t) - (v: t) - (#l: erased nat{l <= SZ.v i}) - (#r: erased nat{SZ.v i < r}) - (#s0: erased (Seq.seq t)) - requires pts_to_range a l r s0 - ensures - exists* s. - pts_to_range a l r s ** - pure( - eq2 #int (Seq.length s0) (r - l) /\ - s == Seq.upd s0 (SZ.v i - l) v - ) - -ghost -fn pts_to_range_share - (#a:Type) - (arr:array a) - (#l #r: nat) - (#s:Seq.seq a) - (#p:perm) - requires pts_to_range arr l r #p s - ensures pts_to_range arr l r #(p /. 2.0R) s ** - pts_to_range arr l r #(p /. 2.0R) s - -[@@allow_ambiguous] -ghost -fn pts_to_range_gather - (#a:Type) - (arr:array a) - (#l #r: nat) - (#s0 #s1: Seq.seq a) - (#p0 #p1:perm) - requires pts_to_range arr l r #p0 s0 ** pts_to_range arr l r #p1 s1 - ensures pts_to_range arr l r #(p0 +. p1) s0 ** - pure (s0 == s1) - -(* Called by elaboration, not to be used directly. *) -fn with_local u#a - (#a:Type0) - (init:a) - (len:SZ.t) - (#pre:slprop) - (ret_t:Type u#a) - (#post:ret_t -> slprop) - (body:(arr:array a) -> stt ret_t (pre ** - (pts_to arr (Seq.create (SZ.v len) init) ** - (pure (is_full_array arr) ** - pure (length arr == SZ.v len)))) - (fun r -> post r ** (exists* v. pts_to arr v))) - requires pre - returns r: ret_t - ensures post r + Seq.index v' k == (if i <= k && k < j then Seq.index vsub (k - i) else Seq.index v k))) \ No newline at end of file diff --git a/lib/pulse/lib/Pulse.Lib.HigherArray.PtsTo.fst b/lib/pulse/lib/Pulse.Lib.Array.PtsTo.fst similarity index 87% rename from lib/pulse/lib/Pulse.Lib.HigherArray.PtsTo.fst rename to lib/pulse/lib/Pulse.Lib.Array.PtsTo.fst index 6ef5e6062..95cc332b6 100644 --- a/lib/pulse/lib/Pulse.Lib.HigherArray.PtsTo.fst +++ b/lib/pulse/lib/Pulse.Lib.Array.PtsTo.fst @@ -14,7 +14,7 @@ limitations under the License. *) -module Pulse.Lib.HigherArray.PtsTo +module Pulse.Lib.Array.PtsTo #lang-pulse open Pulse.Main open FStar.Tactics.V2 @@ -193,4 +193,21 @@ fn pts_to_perm_bound u#a (#a: Type u#a) (#p:_) (arr: array a) (#s:Seq.seq a) unfold pts_to arr #p s; pts_to_mask_perm_bound arr; fold pts_to arr #p s; +} + +fn with_local u#a (#a:Type0) (init:a) (len:SZ.t) (#pre:slprop) (ret_t:Type u#a) + (#post:ret_t -> slprop) + (body:(arr:array a) -> stt ret_t (pre ** + (pts_to arr (Seq.create (SZ.v len) init) ** + (pure (is_full_array arr) ** + pure (length arr == SZ.v len)))) + (fun r -> post r ** (exists* v. pts_to arr v))) + requires pre + returns r: ret_t + ensures post r +{ + let arr = alloc init len; + let r = body arr; + free arr; + r } \ No newline at end of file diff --git a/lib/pulse/lib/Pulse.Lib.HigherArray.PtsTo.fsti b/lib/pulse/lib/Pulse.Lib.Array.PtsTo.fsti similarity index 86% rename from lib/pulse/lib/Pulse.Lib.HigherArray.PtsTo.fsti rename to lib/pulse/lib/Pulse.Lib.Array.PtsTo.fsti index 490757bf0..cc7f74a19 100644 --- a/lib/pulse/lib/Pulse.Lib.HigherArray.PtsTo.fsti +++ b/lib/pulse/lib/Pulse.Lib.Array.PtsTo.fsti @@ -14,7 +14,7 @@ limitations under the License. *) -module Pulse.Lib.HigherArray.PtsTo +module Pulse.Lib.Array.PtsTo #lang-pulse open FStar.Tactics.V2 open Pulse.Lib.Core @@ -24,7 +24,7 @@ open PulseCore.FractionalPermission open FStar.Ghost module SZ = FStar.SizeT module Seq = FStar.Seq -open Pulse.Lib.HigherArray.Core +open Pulse.Lib.Array.Core open Pulse.Lib.SmallType val pts_to (#a:Type u#a) ([@@@mkey]x:array a) (#[exact (`1.0R)] p:perm) (s: Seq.seq a) : slprop @@ -137,4 +137,20 @@ ghost fn pts_to_perm_bound u#a (#a: Type u#a) (#p:_) (arr: array a) (#s:Seq.seq a) preserves pts_to arr #p s requires pure (Seq.length s > 0) - ensures pure (p <=. 1.0R) \ No newline at end of file + ensures pure (p <=. 1.0R) + +fn with_local u#a + (#a:Type0) + (init:a) + (len:SZ.t) + (#pre:slprop) + (ret_t:Type u#a) + (#post:ret_t -> slprop) + (body:(arr:array a) -> stt ret_t (pre ** + (pts_to arr (Seq.create (SZ.v len) init) ** + (pure (is_full_array arr) ** + pure (length arr == SZ.v len)))) + (fun r -> post r ** (exists* v. pts_to arr v))) + requires pre + returns r: ret_t + ensures post r \ No newline at end of file diff --git a/lib/pulse/lib/Pulse.Lib.HigherArray.PtsToRange.fst b/lib/pulse/lib/Pulse.Lib.Array.PtsToRange.fst similarity index 99% rename from lib/pulse/lib/Pulse.Lib.HigherArray.PtsToRange.fst rename to lib/pulse/lib/Pulse.Lib.Array.PtsToRange.fst index 2032e0fea..aeb4914c1 100644 --- a/lib/pulse/lib/Pulse.Lib.HigherArray.PtsToRange.fst +++ b/lib/pulse/lib/Pulse.Lib.Array.PtsToRange.fst @@ -14,7 +14,7 @@ limitations under the License. *) -module Pulse.Lib.HigherArray.PtsToRange +module Pulse.Lib.Array.PtsToRange #lang-pulse open Pulse.Main open FStar.Tactics.V2 diff --git a/lib/pulse/lib/Pulse.Lib.HigherArray.PtsToRange.fsti b/lib/pulse/lib/Pulse.Lib.Array.PtsToRange.fsti similarity index 95% rename from lib/pulse/lib/Pulse.Lib.HigherArray.PtsToRange.fsti rename to lib/pulse/lib/Pulse.Lib.Array.PtsToRange.fsti index 1db2c4293..7b8e962dc 100644 --- a/lib/pulse/lib/Pulse.Lib.HigherArray.PtsToRange.fsti +++ b/lib/pulse/lib/Pulse.Lib.Array.PtsToRange.fsti @@ -14,7 +14,7 @@ limitations under the License. *) -module Pulse.Lib.HigherArray.PtsToRange +module Pulse.Lib.Array.PtsToRange #lang-pulse open FStar.Tactics.V2 open Pulse.Lib.Core @@ -24,14 +24,14 @@ open PulseCore.FractionalPermission open FStar.Ghost module SZ = FStar.SizeT module Seq = FStar.Seq -open Pulse.Lib.HigherArray.Core -open Pulse.Lib.HigherArray.PtsTo -open Pulse.Lib.SmallType +open Pulse.Lib.Array.Core +open Pulse.Lib.Array.PtsTo val pts_to_range (#a:Type u#a) ([@@@mkey]x:array a) - ([@@@mkey] i [@@@mkey] j : nat) + ([@@@mkey]i: nat) + (j: nat) (#[exact (`1.0R)] p:perm) (s : Seq.seq a) : slprop diff --git a/lib/pulse/lib/Pulse.Lib.Array.fst b/lib/pulse/lib/Pulse.Lib.Array.fst index d5593db3f..78745deb9 100644 --- a/lib/pulse/lib/Pulse.Lib.Array.fst +++ b/lib/pulse/lib/Pulse.Lib.Array.fst @@ -18,7 +18,7 @@ module Pulse.Lib.Array #lang-pulse open Pulse.Lib.Core open Pulse.Lib.Reference -open Pulse.Lib.Array.Core +open Pulse.Lib.Array.Basic open Pulse.Class.PtsTo open FStar.Ghost module US = FStar.SizeT diff --git a/lib/pulse/lib/Pulse.Lib.Array.fsti b/lib/pulse/lib/Pulse.Lib.Array.fsti index aaa20291b..12a978894 100644 --- a/lib/pulse/lib/Pulse.Lib.Array.fsti +++ b/lib/pulse/lib/Pulse.Lib.Array.fsti @@ -17,10 +17,9 @@ module Pulse.Lib.Array #lang-pulse open Pulse.Lib.Core -include Pulse.Lib.Array.Core +include Pulse.Lib.Array.Basic open PulseCore.FractionalPermission open FStar.Ghost -include Pulse.Lib.Array.Core module SZ = FStar.SizeT module Seq = FStar.Seq module U8 = FStar.UInt8 diff --git a/lib/pulse/lib/Pulse.Lib.ArrayPtr.fst b/lib/pulse/lib/Pulse.Lib.ArrayPtr.fst index a0abd6d57..4b1c86e99 100644 --- a/lib/pulse/lib/Pulse.Lib.ArrayPtr.fst +++ b/lib/pulse/lib/Pulse.Lib.ArrayPtr.fst @@ -19,7 +19,7 @@ module Pulse.Lib.ArrayPtr noeq type ptr t = { - base: A.array t; + base: A.array u#0 t; offset: (offset: SZ.t { SZ.v offset <= A.length base}) } @@ -162,7 +162,7 @@ fn split (#t: Type) (s: ptr t) (#p: perm) (i: SZ.t) with s1. assert A.pts_to_range s.base (SZ.v s.offset) (SZ.v s'.offset) #p s1; rewrite (A.pts_to_range s.base (SZ.v s.offset) (SZ.v s'.offset) #p s1) - as (A.pts_to_range s.base (SZ.v s.offset) (SZ.v s.offset + SZ.v i) #p s1); + as (A.pts_to_range s.base (SZ.v s.offset) (SZ.v s.offset + Seq.length s1) #p s1); fold pts_to s #p s1; with s2. assert A.pts_to_range s.base (SZ.v s'.offset) (SZ.v s.offset + Seq.length v) #p s2; rewrite @@ -191,7 +191,7 @@ ghost fn ghost_split (#t: Type) (s: ptr t) (#p: perm) (i: SZ.t) with s1. assert A.pts_to_range s.base (SZ.v s.offset) (SZ.v s'.offset) #p s1; rewrite (A.pts_to_range s.base (SZ.v s.offset) (SZ.v s'.offset) #p s1) - as (A.pts_to_range s.base (SZ.v s.offset) (SZ.v s.offset + SZ.v i) #p s1); + as (A.pts_to_range s.base (SZ.v s.offset) (SZ.v s.offset + Seq.length s1) #p s1); fold pts_to s #p s1; with s2. assert A.pts_to_range s.base (SZ.v s'.offset) (SZ.v s.offset + Seq.length v) #p s2; rewrite @@ -210,8 +210,8 @@ fn join (#t: Type) (s1: ptr t) (#p: perm) (#v1: Seq.seq t) (s2: ptr t) (#v2: Seq unfold pts_to s1 #p v1; unfold pts_to s2 #p v2; rewrite (A.pts_to_range s2.base (SZ.v s2.offset) (SZ.v s2.offset + Seq.length v2) #p v2) - as (A.pts_to_range s1.base (SZ.v s1.offset + Seq.length v1) (SZ.v s1.offset + Seq.length v1 + Seq.length v2) #p v2); - A.pts_to_range_join s1.base (SZ.v s1.offset) (SZ.v s1.offset + Seq.length v1) (SZ.v s1.offset + Seq.length v1 + Seq.length v2); + as (A.pts_to_range s1.base (SZ.v s1.offset + Seq.length v1) (SZ.v s1.offset + Seq.length (Seq.append v1 v2)) #p v2); + A.pts_to_range_join s1.base (SZ.v s1.offset) (SZ.v s1.offset + Seq.length v1) (SZ.v s1.offset + Seq.length (Seq.append v1 v2)); fold pts_to s1 #p (Seq.append v1 v2) } diff --git a/lib/pulse/lib/Pulse.Lib.BigGhostReference.fst b/lib/pulse/lib/Pulse.Lib.BigGhostReference.fst deleted file mode 100644 index 0242209eb..000000000 --- a/lib/pulse/lib/Pulse.Lib.BigGhostReference.fst +++ /dev/null @@ -1,161 +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.Lib.BigGhostReference -#lang-pulse -open Pulse.Lib.Core -open Pulse.Main -open FStar.PCM -open Pulse.Lib.PCM.Fraction -module T = FStar.Tactics -let ref (a:Type u#2) = ghost_pcm_ref #(fractional a) (pcm_frac #a) - -instance non_informative_gref (a:Type u#2) : NonInformative.non_informative (ref a) = { - reveal = (fun x -> reveal x) <: NonInformative.revealer (ref a); -} - -let pts_to (#a:Type) (r:ref a) (#[T.exact (`1.0R)] p:perm) (n:a) -= big_ghost_pcm_pts_to r (Some (n, p)) ** pure (perm_ok p) - - -ghost -fn full_values_compatible (#a:Type u#2) (x:a) - requires emp - ensures pure (compatible pcm_frac (Some (x, 1.0R)) (Some (x, 1.0R))) -{ - assert pure (FStar.PCM.composable pcm_frac (Some(x, 1.0R)) None); -} - - - -ghost -fn alloc (#a:Type u#2) (x:a) - requires emp - returns r:ref a - ensures pts_to r x -{ - full_values_compatible x; - let r = Pulse.Lib.Core.big_ghost_alloc #_ #(pcm_frac #a) (Some (x, 1.0R)); - fold (pts_to r #1.0R x); - r -} - - -let read_compat (#a:Type u#2) (x:fractional a) - (v:fractional a { compatible pcm_frac x v }) - : GTot (y:fractional a { compatible pcm_frac y v /\ - FStar.PCM.frame_compatible pcm_frac x v y }) - = x - - -ghost -fn read (#a:Type u#2) (r:ref a) (#n:erased a) (#p:perm) - preserves pts_to r #p n - returns x:erased a - ensures rewrites_to x n -{ - unfold pts_to r #p n; - with w. assert (big_ghost_pcm_pts_to r w); - let x = Pulse.Lib.Core.big_ghost_read r w (fun _ -> w); - assert pure (compatible pcm_frac w x); - assert (big_ghost_pcm_pts_to r w); - fold (pts_to r #p n); - hide (fst (Some?.v x)) -} - -let ( ! ) #a = read #a - -ghost -fn write (#a:Type u#2) (r:ref a) (x:erased a) (#n:erased a) - requires pts_to r #1.0R n - ensures pts_to r #1.0R x -{ - unfold pts_to r #1.0R n; - with w. assert (big_ghost_pcm_pts_to r w); - Pulse.Lib.Core.big_ghost_write r _ _ (mk_frame_preserving_upd n x); - fold pts_to r #1.0R x; -} - -let ( := ) #a = write #a - - -ghost -fn free (#a:Type u#2) (r:ref a) (#n:erased a) - requires pts_to r #1.0R n - ensures emp -{ - unfold pts_to r #1.0R n; - Pulse.Lib.Core.big_ghost_write r _ _ (mk_frame_preserving_upd_none n); - Pulse.Lib.Core.drop_ _; -} - - - -ghost -fn share #a (r:ref a) (#v:erased a) (#p:perm) - requires pts_to r #p v - ensures pts_to r #(p /. 2.0R) v ** pts_to r #(p /. 2.0R) v -{ - unfold pts_to r #p v; - rewrite big_ghost_pcm_pts_to r (Some (reveal v, p)) - as big_ghost_pcm_pts_to r (Some (reveal v, p /. 2.0R) `op pcm_frac` Some(reveal v, p /. 2.0R)); - Pulse.Lib.Core.big_ghost_share r (Some (reveal v, p /. 2.0R)) _; //writing an underscore for the first arg also causes a crash - fold (pts_to r #(p /. 2.0R) v); - fold (pts_to r #(p /. 2.0R) v); -} - - - -ghost -fn gather #a (r:ref a) (#x0 #x1:erased a) (#p0 #p1:perm) - requires pts_to r #p0 x0 ** pts_to r #p1 x1 - ensures pts_to r #(p0 +. p1) x0 ** pure (x0 == x1) -{ - unfold pts_to r #p0 x0; - unfold pts_to r #p1 x1; - Pulse.Lib.Core.big_ghost_gather r (Some (reveal x0, p0)) (Some (reveal x1, p1)); - fold (pts_to r #(p0 +. p1) x0) -} - - -ghost -fn pts_to_injective_eq - (#a:Type) - (#p0 #p1:perm) - (#v0 #v1:a) - (r:ref a) - requires pts_to r #p0 v0 ** pts_to r #p1 v1 - ensures pts_to r #p0 v0 ** pts_to r #p1 v1 ** pure (v0 == v1) -{ - unfold pts_to r #p0 v0; - unfold pts_to r #p1 v1; - Pulse.Lib.Core.big_ghost_gather r (Some (v0, p0)) (Some (v1, p1)); - Pulse.Lib.Core.big_ghost_share r (Some (v0, p0)) (Some (v1, p1)); - fold pts_to r #p0 v0; - fold pts_to r #p1 v1; -} - - - -ghost -fn pts_to_perm_bound (#a:_) (#p:_) (r:ref a) (#v:a) - requires pts_to r #p v - ensures pts_to r #p v ** pure (p <=. 1.0R) -{ - unfold pts_to r #p v; - fold pts_to r #p v; -} - diff --git a/lib/pulse/lib/Pulse.Lib.BigGhostReference.fsti b/lib/pulse/lib/Pulse.Lib.BigGhostReference.fsti deleted file mode 100644 index 1abbcdf9a..000000000 --- a/lib/pulse/lib/Pulse.Lib.BigGhostReference.fsti +++ /dev/null @@ -1,96 +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.Lib.BigGhostReference -#lang-pulse -open FStar.Tactics -open Pulse.Lib.Core -open Pulse.Main -open PulseCore.FractionalPermission -open FStar.Ghost - -[@@erasable] -val ref ([@@@unused] a:Type u#2) : Type u#0 - -instance val non_informative_gref (a:Type u#2) : NonInformative.non_informative (ref a) - -val pts_to - (#a:Type) - ([@@@mkey] r:ref a) - (#[exact (`1.0R)] p:perm) - (n:a) -: slprop - -ghost -fn alloc (#a:Type) (x:a) - returns r : ref a - ensures pts_to r x - -ghost -fn read (#a:Type) (r:ref a) (#n:erased a) (#p:perm) - preserves pts_to r #p n - returns x : erased a - ensures rewrites_to x n - -(* = read *) -ghost -fn ( ! ) (#a:Type) (r:ref a) (#n:erased a) (#p:perm) - preserves pts_to r #p n - returns x : erased a - ensures rewrites_to x n - -ghost -fn write (#a:Type) (r:ref a) (x:erased a) (#n:erased a) - requires pts_to r n - ensures pts_to r x - -(* = write *) -ghost -fn ( := ) (#a:Type) (r:ref a) (x:erased a) (#n:erased a) - requires pts_to r n - ensures pts_to r x - -ghost -fn free (#a:Type) (r:ref a) (#n:erased a) - requires pts_to r n - ensures emp - -ghost -fn share (#a:Type) (r:ref a) (#v:erased a) (#p:perm) - requires pts_to r #p v - ensures - pts_to r #(p /. 2.0R) v ** - pts_to r #(p /. 2.0R) v - -[@@allow_ambiguous] -ghost -fn gather (#a:Type) (r:ref a) (#x0 #x1:erased a) (#p0 #p1:perm) - requires pts_to r #p0 x0 ** pts_to r #p1 x1 - ensures pts_to r #(p0 +. p1) x0 ** pure (x0 == x1) - -[@@allow_ambiguous] -ghost -fn pts_to_injective_eq (#a:_) - (#p #q:_) - (#v0 #v1:a) - (r:ref a) - requires pts_to r #p v0 ** pts_to r #q v1 - ensures pts_to r #p v0 ** pts_to r #q v1 ** pure (v0 == v1) - -ghost -fn pts_to_perm_bound (#a:_) (#p:_) (r:ref a) (#v:a) - requires pts_to r #p v - ensures pts_to r #p v ** pure (p <=. 1.0R) diff --git a/lib/pulse/lib/Pulse.Lib.Borrow.fst b/lib/pulse/lib/Pulse.Lib.Borrow.fst index 779567f97..264eaef84 100644 --- a/lib/pulse/lib/Pulse.Lib.Borrow.fst +++ b/lib/pulse/lib/Pulse.Lib.Borrow.fst @@ -43,7 +43,7 @@ type lifetime : Type0 = let fpts_to #t (r: ref t) (x: t) = exists* p. pts_to r #p x -ghost fn dup_fpts_to t r x () : duplicable_f (fpts_to #t r x) = { +ghost fn dup_fpts_to u#t (t: Type u#t) r x () : duplicable_f (fpts_to #t r x) = { unfold fpts_to r x; share r; fold fpts_to r x; @@ -391,7 +391,7 @@ ghost fn rec set_end (a: lifetime) (n: unat) (y: blockchain_root) } } -ghost fn fpts_to_gather #t (x: ref t) y y' +ghost fn fpts_to_gather u#t (#t: Type u#t) (x: ref t) y y' preserves fpts_to x y requires fpts_to x y' ensures pure (y == y') @@ -697,7 +697,7 @@ ghost fn fpts_to_of_root_idx' x j r } [@@allow_ambiguous] -ghost fn too_much_perm #t (x: ref t) #y1 #y2 #p1 #p2 +ghost fn too_much_perm u#t (#t: Type u#t) (x: ref t) #y1 #y2 #p1 #p2 requires pts_to x #p1 y1 requires pts_to x #p2 y2 requires pure (p1 +. p2 >. 1.0R) diff --git a/lib/pulse/lib/Pulse.Lib.Box.fst b/lib/pulse/lib/Pulse.Lib.Box.fst index dbf899c7c..7bb86a223 100644 --- a/lib/pulse/lib/Pulse.Lib.Box.fst +++ b/lib/pulse/lib/Pulse.Lib.Box.fst @@ -23,7 +23,7 @@ module R = Pulse.Lib.Reference #lang-pulse noeq -type box a = | B : r:R.ref a -> box a +type box a = | B : r:R.ref u#0 a -> box a let null (#a:Type u#0) : box a = B R.null diff --git a/lib/pulse/lib/Pulse.Lib.GhostFractionalTable.fst b/lib/pulse/lib/Pulse.Lib.GhostFractionalTable.fst index 9cfc2aa71..159178a6a 100644 --- a/lib/pulse/lib/Pulse.Lib.GhostFractionalTable.fst +++ b/lib/pulse/lib/Pulse.Lib.GhostFractionalTable.fst @@ -77,7 +77,7 @@ ensures } ghost -fn take_i #a (r:GPR.gref (a_map a)) (n:nat) +fn take_i (#a:Type0) (r:GPR.gref (a_map a)) (n:nat) requires GPR.pts_to r (full_table_above n) ensures diff --git a/lib/pulse/lib/Pulse.Lib.GhostPCMReference.fst b/lib/pulse/lib/Pulse.Lib.GhostPCMReference.fst index 32fba21e1..5824a85d5 100644 --- a/lib/pulse/lib/Pulse.Lib.GhostPCMReference.fst +++ b/lib/pulse/lib/Pulse.Lib.GhostPCMReference.fst @@ -1,46 +1,70 @@ +(* + 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.GhostPCMReference #lang-pulse -open Pulse.Lib.Pervasives open FStar.PCM module PR = Pulse.Lib.PCM.Raise module U = Pulse.Lib.Raise +module C = Pulse.Lib.Core.Refs +open Pulse.Lib.PCM.Raise +open FStar.Ghost -let pts_to - (#a:Type u#0) - (#p:pcm a) - (r:gref p) - (v:a) -: slprop -= ghost_pcm_pts_to #_ #(PR.raise p) r (U.raise_val v) +let core_ghost_pcm_ref = C.core_ghost_pcm_ref +let null_core_ghost_pcm_ref = C.null_core_ghost_pcm_ref + + +let small_token (inst: small_type u#a) = emp + +[@@pulse_unfold] +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 -let pts_to_is_timeless #a #p r v = () +let pts_to_is_timeless #a #p r v = + assert_norm (pts_to r v == + op_exists_Star fun (inst: small_type u#a) -> + C.ghost_pcm_pts_to #_ #(raise p) r (U.raise_val v) ** small_token inst) -let alloc #a #p x = ghost_alloc #_ #(PR.raise p) (U.raise_val x) +ghost +fn alloc u#a (#a:Type u#a) + (#pcm:pcm a) + {| inst: small_type u#a |} + (x:a{pcm.refine x}) + requires emp + returns r : gref pcm + ensures pts_to r x +{ + fold small_token u#a inst; + C.ghost_alloc #(U.raise_t a) #(raise pcm) (U.raise_val x); +} ghost -fn read - (#a:Type u#0) +fn read u#a + (#a:Type u#a) (#p:pcm a) (r:gref p) (x:a) - (f: (v:a{FStar.PCM.compatible #a p (reveal x) v} + (f: (v:a{FStar.PCM.compatible #a p x v} -> GTot (y:a{compatible p y v /\ FStar.PCM.frame_compatible p x v y}))) requires pts_to r x returns v:(v:a { compatible p x v /\ p.refine v }) ensures pts_to r (f v) { - unfold pts_to; - rewrite ghost_pcm_pts_to #_ #(PR.raise p) r (U.raise_val u#0 u#1 x) - as ghost_pcm_pts_to #_ #(PR.raise p) r (reveal (hide (U.raise_val x))); - let v0 = ghost_read #_ #(PR.raise u#0 u#1 p) r (U.raise_val x) (PR.raise_refine u#0 u#1 p x f); - let v = U.downgrade_val u#0 u#1 (Ghost.reveal v0); - let vv = (PR.raise_refine u#0 u#1 #_ p x f (reveal v0)); - rewrite - ghost_pcm_pts_to #(U.raise_t u#0 u#1 a) #(PR.raise u#0 u#1 p) r vv - as ghost_pcm_pts_to #(U.raise_t u#0 u#1 a) #(PR.raise u#0 u#1 p) r (U.raise_val u#0 u#1 (f v)); - fold (pts_to r (f v)); - v + with inst. assert small_token u#a inst; let inst = inst; + U.downgrade_val (C.ghost_read #(U.raise_t a) #(raise p) r (hide (U.raise_val (reveal x))) (raise_refine p x f)); } @@ -58,38 +82,67 @@ let read_simple (#x:a) = read #a #p r x (identity_frame_compatible p x) -let write - (#a:Type) +ghost +fn write u#a + (#a:Type u#a) (#p:pcm a) (r:gref p) (x y:a) (f:FStar.PCM.frame_preserving_upd p x y) -: stt_ghost unit - emp_inames - (pts_to r x) - (fun _ -> pts_to r y) -= ghost_write #_ #(PR.raise p) r (U.raise_val x) (U.raise_val y) - (PR.raise_upd f) - -let share - (#a:Type) + requires pts_to r x + ensures pts_to r y +{ + with inst. assert small_token u#a inst; let inst = inst; + C.ghost_write #(U.raise_t a) #(raise p) r (hide (U.raise_val (reveal x))) (hide (U.raise_val (reveal y))) + (raise_upd f) +} + +ghost +fn share u#a + (#a:Type u#a) (#pcm:pcm a) (r:gref pcm) (v0:a) (v1:a{composable pcm v0 v1}) -: stt_ghost unit - emp_inames - (pts_to r (v0 `op pcm` v1)) - (fun _ -> pts_to r v0 ** pts_to r v1) -= ghost_share #_ #(PR.raise pcm) r (U.raise_val v0) (U.raise_val v1) + requires pts_to r (v0 `op pcm` v1) + ensures pts_to r v0 ** pts_to r v1 +{ + with inst. assert small_token u#a inst; let inst = inst; + fold small_token u#a inst; + C.ghost_share #_ #(PR.raise pcm) r (U.raise_val v0) (U.raise_val v1) +} -let gather - (#a:Type) +[@@allow_ambiguous] +ghost fn drop_amb (p: slprop) + requires p +{ + drop_ p +} + +[@@allow_ambiguous] +ghost +fn gather u#a + (#a:Type u#a) (#pcm:pcm a) (r:gref pcm) - (v0 v1:a) -: stt_ghost (squash (composable pcm v0 v1)) - emp_inames - (pts_to r v0 ** pts_to r v1) - (fun _ -> pts_to r (op pcm v0 v1)) -= ghost_gather #_ #(PR.raise pcm) r (U.raise_val v0) (U.raise_val v1) + (v0:a) + (v1:a) + requires pts_to r v0 ** pts_to r v1 + returns squash (composable pcm v0 v1) + ensures pts_to r (op pcm v0 v1) +{ + with inst. assert C.ghost_pcm_pts_to #_ #(raise #a #inst pcm) r (U.raise_val v1); + with inst'. assert C.ghost_pcm_pts_to #_ #(raise #a #inst' pcm) r (U.raise_val v1); + drop_amb (small_token u#a inst'); + let inst = inst; + C.ghost_gather #_ #(PR.raise pcm) r (U.raise_val v0) (U.raise_val v1) +} + +ghost fn pts_to_not_null u#a (#a:Type u#a) + (#p:pcm a) (r:gref p) (v:a) + preserves pts_to r v + ensures pure (r =!= ghost_pcm_ref_null p) +{ + C.ghost_pts_to_not_null r _; + () +} \ No newline at end of file diff --git a/lib/pulse/lib/Pulse.Lib.GhostPCMReference.fsti b/lib/pulse/lib/Pulse.Lib.GhostPCMReference.fsti index f1ef40396..b6a16f9ea 100644 --- a/lib/pulse/lib/Pulse.Lib.GhostPCMReference.fsti +++ b/lib/pulse/lib/Pulse.Lib.GhostPCMReference.fsti @@ -1,21 +1,54 @@ +(* + 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.GhostPCMReference #lang-pulse -open Pulse.Lib.Pervasives +open Pulse.Lib.SmallType +open Pulse.Lib.Core +open Pulse.Main open FStar.PCM -let gref (#a:Type0) (p:pcm a) +[@@erasable] +val core_ghost_pcm_ref : Type0 + +val null_core_ghost_pcm_ref : core_ghost_pcm_ref + +[@@erasable] +let ghost_pcm_ref (#a: Type u#a) (p: pcm a) : Type0 = core_ghost_pcm_ref + +let ghost_pcm_ref_null #a (p:pcm a) : ghost_pcm_ref p = null_core_ghost_pcm_ref + +inline_for_extraction +instance non_informative_ghost_pcm_ref (a: Type u#a) (p:pcm a) + : NonInformative.non_informative (ghost_pcm_ref p) = + { reveal = ((fun x -> x) <: NonInformative.revealer (ghost_pcm_ref p)) } + +[@@erasable] +let gref (#a:Type) (p:pcm a) : Type0 = ghost_pcm_ref #a p val pts_to - (#a:Type u#0) + (#a:Type) (#p:pcm a) ([@@@mkey]r:gref p) (v:a) : slprop val pts_to_is_timeless - (#a:Type u#0) + (#a:Type) (#p:pcm a) (r:gref p) (v:a) @@ -23,17 +56,17 @@ val pts_to_is_timeless [SMTPat (timeless (pts_to r v))] ghost -fn alloc - (#a:Type u#0) +fn alloc u#a (#a:Type u#a) (#pcm:pcm a) + {| inst: small_type u#a |} (x:a{pcm.refine x}) requires emp returns r : gref pcm ensures pts_to r x ghost -fn read - (#a:Type) +fn read u#a + (#a:Type u#a) (#p:pcm a) (r:gref p) (x:a) @@ -46,8 +79,8 @@ fn read ensures pts_to r (f v) ghost -fn read_simple - (#a:Type) +fn read_simple u#a + (#a:Type u#a) (#p:pcm a) (r:gref p) (#x:a) @@ -56,8 +89,8 @@ fn read_simple ensures pts_to r x ghost -fn write - (#a:Type) +fn write u#a + (#a:Type u#a) (#p:pcm a) (r:gref p) (x y:a) @@ -66,8 +99,8 @@ fn write ensures pts_to r y ghost -fn share - (#a:Type) +fn share u#a + (#a:Type u#a) (#pcm:pcm a) (r:gref pcm) (v0:a) @@ -77,8 +110,8 @@ fn share [@@allow_ambiguous] ghost -fn gather - (#a:Type) +fn gather u#a + (#a:Type u#a) (#pcm:pcm a) (r:gref pcm) (v0:a) @@ -86,3 +119,8 @@ fn gather requires pts_to r v0 ** pts_to r v1 returns squash (composable pcm v0 v1) ensures pts_to r (op pcm v0 v1) + +ghost fn pts_to_not_null u#a (#a:Type u#a) + (#p:pcm a) (r:gref p) (v:a) + preserves pts_to r v + ensures pure (r =!= ghost_pcm_ref_null p) \ No newline at end of file diff --git a/lib/pulse/lib/Pulse.Lib.GhostReference.fst b/lib/pulse/lib/Pulse.Lib.GhostReference.fst index e148b76aa..9864ebf12 100644 --- a/lib/pulse/lib/Pulse.Lib.GhostReference.fst +++ b/lib/pulse/lib/Pulse.Lib.GhostReference.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. @@ -18,152 +18,147 @@ module Pulse.Lib.GhostReference #lang-pulse open Pulse.Lib.Core open Pulse.Main -module H = Pulse.Lib.HigherGhostReference -module U = Pulse.Lib.Raise -let ref a = H.ref (U.raise_t a) +open FStar.PCM +open Pulse.Lib.PCM.Fraction +module GR = Pulse.Lib.GhostPCMReference +module T = FStar.Tactics +let ref a = GR.ghost_pcm_ref #_ (pcm_frac #a) -let null #a = H.null +let null #a = GR.null_core_ghost_pcm_ref -instance non_informative_gref (a:Type0) : NonInformative.non_informative (ref a) = { - reveal = (fun x -> Ghost.reveal x) <: NonInformative.revealer (ref a); -} - -let pts_to - (#a:Type u#0) - ([@@@mkey] r:ref a) - (#[exact (`1.0R)] p:perm) - (v:a) - = H.pts_to r #p (U.raise_val v) +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_timeless r p x = H.pts_to_timeless r p (U.raise_val x) +let pts_to_timeless _ _ _ = () ghost -fn alloc (#a:Type u#0) (v:a) +fn full_values_compatible u#a (#a:Type u#a) (x:a) requires emp - returns r:ref a - ensures pts_to r v + ensures pure (compatible pcm_frac (Some (x, 1.0R)) (Some (x, 1.0R))) { - let r = H.alloc (U.raise_val v); - fold (pts_to r #1.0R v); - r + assert pure (FStar.PCM.composable pcm_frac (Some(x, 1.0R)) None); } - ghost -fn read (#a:Type) (r:ref a) (#n:erased a) (#p:perm) - preserves pts_to r #p n - returns x:erased a - ensures rewrites_to x n +fn alloc u#a (#a:Type u#a) {| small_type u#a |} (x:a) + returns r : ref a + ensures r |-> x { - unfold (pts_to r #p n); - let k = H.( !r ); - fold (pts_to r #p n); - hide (U.downgrade_val (reveal k)) + full_values_compatible x; + let r = GR.alloc #_ #(pcm_frac #a) (Some (x, 1.0R)); + fold (pts_to r #1.0R x); + r } -let ( ! ) #a = read #a ghost -fn write (#a:Type) (r:ref a) (x:erased a) (#n:erased a) - requires pts_to r #1.0R n - ensures pts_to r #1.0R x +fn read u#a (#a:Type u#a) (r:ref a) (#n:erased a) (#p:perm) + preserves r |-> Frac p n + returns x : erased a + ensures rewrites_to x n { - unfold (pts_to r #1.0R n); - H.(r := (U.raise_val x)); - fold (pts_to r #1.0R x) + unfold pts_to r #p n; + with w. assert (GR.pts_to r w); + let x = GR.read r w (fun _ -> w); + assert pure (compatible pcm_frac w x); + assert (GR.pts_to r w); + fold (pts_to r #p n); + hide (fst (Some?.v x)) } -let ( := ) = write + +let ( ! ) #a = read #a + ghost -fn free #a (r:ref a) (#n:erased a) - requires pts_to r #1.0R n - ensures emp +fn ( := ) u#a (#a:Type u#a) (r:ref a) (x:erased a) (#n:erased a) + requires r |-> n + ensures r |-> x { - unfold (pts_to r #1.0R n); - H.free r; + unfold pts_to r #1.0R n; + with w. assert (GR.pts_to r w); + GR.write r _ _ (mk_frame_preserving_upd n x); + fold pts_to r #1.0R x; } +let write = ( := ) ghost -fn share (#a:Type) (r:ref a) (#v:erased a) (#p:perm) - requires pts_to r #p v - ensures pts_to r #(p /. 2.0R) v ** pts_to r #(p /. 2.0R) v +fn free u#a (#a:Type u#a) (r:ref a) (#n:erased a) + requires pts_to r n + ensures emp { - unfold pts_to r #p v; - H.share r; - fold pts_to r #(p /. 2.0R) v; - fold pts_to r #(p /. 2.0R) v + unfold pts_to r #1.0R n; + GR.write r _ _ (mk_frame_preserving_upd_none n); + drop_ (GR.pts_to r _); } - + ghost -fn raise_inj (a:Type u#0) (x0 x1:a) - requires pure (U.raise_val u#0 u#1 x0 == U.raise_val u#0 u#1 x1) - ensures pure (x0 == x1) +fn share u#a (#a:Type u#a) (r:ref a) (#v:erased a) (#p:perm) + requires r |-> Frac p v + ensures (r |-> Frac (p /. 2.0R) v) ** + (r |-> Frac (p /. 2.0R) v) { - assert pure (U.downgrade_val (U.raise_val u#0 u#1 x0) == x0); - assert pure (U.downgrade_val (U.raise_val u#0 u#1 x1) == x1); + unfold pts_to r #p v; + GR.share r (Some (reveal v, p /. 2.0R)) (Some (reveal v, p /. 2.0R)); + fold (pts_to r #(p /. 2.0R) v); + fold (pts_to r #(p /. 2.0R) v); } - +[@@allow_ambiguous] ghost -fn gather (#a:Type) (r:ref a) (#x0 #x1:erased a) (#p0 #p1:perm) - requires pts_to r #p0 x0 ** pts_to r #p1 x1 - ensures pts_to r #(p0 +. p1) x0 ** pure (x0 == x1) -{ +fn gather u#a (#a:Type u#a) (r:ref a) (#x0 #x1:erased a) (#p0 #p1:perm) + requires (r |-> Frac p0 x0) ** (r |-> Frac p1 x1) + ensures (r |-> Frac (p0 +. p1) x0) ** pure (x0 == x1) +{ unfold pts_to r #p0 x0; unfold pts_to r #p1 x1; - H.gather r; - fold (pts_to r #(p1 +. p0) x0); - raise_inj a x0 x1; + GR.gather r (Some (reveal x0, p0)) (Some (reveal x1, p1)); + fold (pts_to r #(p0 +. p1) x0) } - - +[@@allow_ambiguous] ghost -fn pts_to_injective_eq - (#a:Type0) - (#p #q:perm) - (#v0 #v1:a) - (r:ref a) -requires - pts_to r #p v0 ** pts_to r #q v1 -ensures - (pts_to r #p v0 ** pts_to r #q v1) ** pure (v0 == v1) +fn pts_to_injective_eq u#a (#a:Type u#a) + (#p #q:_) + (#v0 #v1:a) + (r:ref a) + requires (r |-> Frac p v0) ** (r |-> Frac q v1) + ensures (r |-> Frac p v0) ** (r |-> Frac q v1) ** pure (v0 == v1) { unfold pts_to r #p v0; unfold pts_to r #q v1; - H.pts_to_injective_eq r; + GR.gather r (Some (v0, p)) (Some (v1, q)); + GR.share r (Some (v0, p)) (Some (v1, q)); fold pts_to r #p v0; fold pts_to r #q v1; - raise_inj _ v0 v1; } ghost -fn pts_to_perm_bound (#a:_) (#p:_) (r:ref a) (#v:a) - requires pts_to r #p v - ensures pts_to r #p v ** pure (p <=. 1.0R) +fn pts_to_perm_bound u#a (#a:Type u#a) (#p:_) (r:ref a) (#v:a) + requires r |-> Frac p v + ensures (r |-> Frac p v) ** pure (p <=. 1.0R) { unfold pts_to r #p v; - H.pts_to_perm_bound r; fold pts_to r #p v; } + ghost -fn pts_to_not_null #a (#p:_) (r:ref a) (#v:a) +fn pts_to_not_null u#a (#a:Type u#a) (#p:_) (r:ref a) (#v:a) preserves r |-> Frac p v ensures pure (r =!= null) { unfold pts_to r #p v; - H.pts_to_not_null r; + GR.pts_to_not_null r _; fold pts_to r #p v; } \ No newline at end of file diff --git a/lib/pulse/lib/Pulse.Lib.GhostReference.fsti b/lib/pulse/lib/Pulse.Lib.GhostReference.fsti index 159c7fb93..d1f633f45 100644 --- a/lib/pulse/lib/Pulse.Lib.GhostReference.fsti +++ b/lib/pulse/lib/Pulse.Lib.GhostReference.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. @@ -19,93 +19,97 @@ module Pulse.Lib.GhostReference open FStar.Tactics open Pulse.Lib.Core open Pulse.Main -open Pulse.Class.PtsTo open PulseCore.FractionalPermission open FStar.Ghost +open Pulse.Class.PtsTo +open Pulse.Lib.SmallType [@@erasable] -val ref ([@@@unused] a:Type u#0) : Type u#0 +val ref ([@@@unused] a:Type u#a) : Type u#0 val null #a : ref a - -instance val non_informative_gref (a:Type0) - : NonInformative.non_informative (ref a) - -val pts_to (#a:Type) - ([@@@mkey] r:ref a) - (#[exact (`1.0R)] p:perm) - (n:a) + +inline_for_extraction +instance non_informative_gref (a:Type u#a) + : NonInformative.non_informative (ref a) = + { reveal = ((fun x -> x) <: NonInformative.revealer (ref a)) } + +val pts_to + (#a:Type u#a) + ([@@@mkey] r:ref a) + (#[exact (`1.0R)] p:perm) + (n:a) : slprop [@@pulse_unfold] -instance has_pts_to_ref (a:Type) : has_pts_to (ref a) a = { +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); } -val pts_to_timeless (#a:Type) (r:ref a) (p:perm) (x:a) - : Lemma (timeless (pts_to r #p x)) - [SMTPat (timeless (pts_to r #p x))] +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))] ghost -fn alloc (#a:Type) (x:a) +fn alloc u#a (#a:Type u#a) {| small_type u#a |} (x:a) returns r : ref a ensures r |-> x ghost -fn read (#a:Type) (r:ref a) (#n:erased a) (#p:perm) +fn read u#a (#a:Type u#a) (r:ref a) (#n:erased a) (#p:perm) preserves r |-> Frac p n returns x : erased a ensures rewrites_to x n -(* alias for read *) +(* alias for read *) ghost -fn ( ! ) (#a:Type) (r:ref a) (#n:erased a) (#p:perm) - preserves r |-> Frac p n +fn ( ! ) u#a (#a:Type u#a) (r:ref a) (#n:erased a) (#p:perm) + preserves pts_to r #p n returns x : erased a ensures rewrites_to x n ghost -fn write (#a:Type) (r:ref a) (x:erased a) (#n:erased a) +fn write u#a (#a:Type u#a) (r:ref a) (x:erased a) (#n:erased a) requires r |-> n ensures r |-> x (* alias for write *) ghost -fn ( := ) (#a:Type) (r:ref a) (x:erased a) (#n:erased a) +fn ( := ) u#a (#a:Type u#a) (r:ref a) (x:erased a) (#n:erased a) requires r |-> n ensures r |-> x ghost -fn free (#a:Type) (r:ref a) (#n:erased a) - requires r |-> n +fn free u#a (#a:Type u#a) (r:ref a) (#n:erased a) + requires pts_to r n ensures emp ghost -fn share (#a:Type) (r:ref a) (#v:erased a) (#p:perm) +fn share u#a (#a:Type u#a) (r:ref a) (#v:erased a) (#p:perm) requires r |-> Frac p v - ensures (r |-> Frac (p /. 2.0R) v) ** (r |-> Frac (p /. 2.0R) v) + ensures (r |-> Frac (p /. 2.0R) v) ** + (r |-> Frac (p /. 2.0R) v) [@@allow_ambiguous] ghost -fn gather (#a:Type) (r:ref a) (#x0 #x1:erased a) (#p0 #p1:perm) +fn gather u#a (#a:Type u#a) (r:ref a) (#x0 #x1:erased a) (#p0 #p1:perm) requires (r |-> Frac p0 x0) ** (r |-> Frac p1 x1) ensures (r |-> Frac (p0 +. p1) x0) ** pure (x0 == x1) [@@allow_ambiguous] ghost -fn pts_to_injective_eq (#a:_) +fn pts_to_injective_eq u#a (#a:Type u#a) (#p #q:_) (#v0 #v1:a) (r:ref a) - preserves (r |-> Frac p v0) ** (r |-> Frac q v1) - ensures pure (v0 == v1) + requires (r |-> Frac p v0) ** (r |-> Frac q v1) + ensures (r |-> Frac p v0) ** (r |-> Frac q v1) ** pure (v0 == v1) ghost -fn pts_to_perm_bound (#a:_) (#p:_) (r:ref a) (#v:a) - preserves r |-> Frac p v - ensures pure (p <=. 1.0R) +fn pts_to_perm_bound u#a (#a:Type u#a) (#p:_) (r:ref a) (#v:a) + requires r |-> Frac p v + ensures (r |-> Frac p v) ** pure (p <=. 1.0R) ghost -fn pts_to_not_null #a (#p:_) (r:ref a) (#v:a) +fn pts_to_not_null u#a (#a:Type u#a) (#p:_) (r:ref a) (#v:a) preserves r |-> Frac p v ensures pure (r =!= null) \ No newline at end of file diff --git a/lib/pulse/lib/Pulse.Lib.HigherArray.Core.fst b/lib/pulse/lib/Pulse.Lib.HigherArray.Core.fst deleted file mode 100644 index 4733e028c..000000000 --- a/lib/pulse/lib/Pulse.Lib.HigherArray.Core.fst +++ /dev/null @@ -1,523 +0,0 @@ -(* - 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.HigherArray.Core -#lang-pulse -open Pulse.Main -open FStar.Tactics.V2 -open Pulse.Lib.Core -open PulseCore.FractionalPermission -open FStar.Ghost -module SZ = FStar.SizeT -module Seq = FStar.Seq -open FStar.PCM -module Frac = Pulse.Lib.PCM.Fraction -module PM = Pulse.Lib.PCM.Map -open Pulse.Lib.PCM.Array -module PA = Pulse.Lib.PCM.Array -open Pulse.Lib.SmallType.PCM - - -/// An abstract type to represent a base array (whole allocation -/// unit), exposed for proof purposes only -[@@erasable] -noeq type base_t : Type0 = { - base_len: base_len:nat { SZ.fits base_len }; - base_ref: base_ref:core_pcm_ref { - base_ref == null_core_pcm_ref ==> base_len == 0 - }; -} - -noeq -type array' : Type0 = { - base_len: base_len:Ghost.erased nat { SZ.fits base_len }; - base_ref: base_ref:core_pcm_ref { - base_ref == null_core_pcm_ref ==> base_len == hide 0 - }; - offset: offset: nat { offset <= base_len }; - length: length:Ghost.erased nat {offset + length <= base_len }; -} -let array elt = array' - -let null_array' : array' = { base_len = 0; base_ref = null_core_pcm_ref; offset = 0; length = 0 } - -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 } -let offset_of #t (a: array t) : GTot nat = a.offset - -let is_full_array (#elt: Type) (a: array elt) : Tot prop = - length a == reveal a.base_len - -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) = - 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 -> - if off <= i && i < off + Seq.length v && mask (i - off) then - Some (Seq.index v (i - off), f) - else - None - -[@@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) - -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 mask_nonempty (mask: nat -> prop) (len: nat) : prop = - exists i. mask i /\ i < len - -// workaround for https://github.com/FStarLang/pulse/issues/430 -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) ** - pure (Seq.length v == reveal a.length /\ (mask_nonempty mask a.length ==> f <=. 1.0R) /\ squash' t) - -let pts_to_mask_timeless _ _ _ _ = () - -ghost -fn pts_to_mask_props u#a (#t: Type u#a) (a:array t) (#p:perm) (#x:Seq.seq t) #mask - preserves pts_to_mask a #p x mask - ensures pure (length a == Seq.length x) - ensures pure (mask_nonempty mask (length a) ==> p <=. 1.0R) - ensures pure (~(is_null a)) - ensures pure (squash' t) -{ - unfold pts_to_mask a #p x mask; - pts_to_not_null (lptr_of a) _; - fold pts_to_mask a #p x mask; -} - -ghost -fn pts_to_mask_len u#a (#t: Type u#a) (a:array t) (#p:perm) (#x:Seq.seq t) #mask - preserves pts_to_mask a #p x mask - ensures pure (length a == Seq.length x) -{ - pts_to_mask_props a; -} - -ghost -fn pts_to_mask_perm_bound u#a (#t: Type u#a) (arr: array t) #p (#s:Seq.seq t) #mask - preserves pts_to_mask arr #p s mask - requires pure (exists (i: nat). i < Seq.length s /\ mask i) - ensures pure (p <=. 1.0R) -{ - pts_to_mask_props arr; -} - -ghost -fn pts_to_mask_not_null u#a (#a: Type u#a) #p (r:array a) (#v:Seq.seq a) #mask - preserves pts_to_mask r #p v mask - ensures pure (not (is_null r)) -{ - pts_to_mask_props r; -} - -ghost fn mask_vext u#a (#t: Type u#a) (arr: array t) #f #v v' #mask - requires pts_to_mask arr #f v mask - requires pure (Seq.length v' == Seq.length v /\ - (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 -{ - unfold pts_to_mask arr #f v mask; - assert pure (mk_carrier' arr f v mask `Map.equal` mk_carrier' arr f v' mask); - fold pts_to_mask arr #f v' mask; -} - -ghost fn mask_mext u#a (#t: Type u#a) (arr: array t) #f #v #mask (mask': nat -> prop) - requires pts_to_mask arr #f v mask - requires pure (forall (i: nat). i < Seq.length v ==> (mask i <==> mask' i)) - 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'); - fold pts_to_mask arr #f v mask'; -} - -ghost fn mask_ext u#a (#t: Type u#a) (arr: array t) #f #v #mask v' (mask': nat -> prop) - requires pts_to_mask arr #f v mask - requires pure (forall (i: nat). i < Seq.length v ==> (mask i <==> mask' i)) - requires pure (Seq.length v' == Seq.length v /\ - (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' -{ - mask_vext arr v'; - mask_mext arr mask'; -} - -[@@noextract_to "krml"] -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) -{ - 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; - pts_to_not_null b _; - let arr: array elt = { base_ref = b; base_len = SZ.v n; length = SZ.v n; offset = 0 }; - 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)); - intro_squash x; - fold pts_to_mask arr (Seq.create (SZ.v n) x) (fun _ -> l_True); - 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 - requires pure (forall i. mask i) - requires pure (is_full_array a) -{ - drop_ (pts_to_mask a s mask); -} - -let get_mask_idx (m: nat->prop) (l: nat) : GTot (i: nat { mask_nonempty m l ==> i < l /\ m i }) = - if IndefiniteDescription.strong_excluded_middle (mask_nonempty m l) then - IndefiniteDescription.indefinite_description_ghost nat fun i -> i < l /\ m i - else - 0 - -ghost fn pcm_rw u#a (#t: Type u#a) - (a1: array t) p1 s1 m1 - (a2: array t) p2 s2 m2 - requires pts_to_mask #t a1 #p1 s1 m1 - requires pure ( - a1.base_len == a2.base_len /\ - a1.base_ref == a2.base_ref /\ - reveal a2.length == Seq.length s2 /\ - mk_carrier' a1 p1 s1 m1 `Map.equal` mk_carrier' a2 p2 s2 m2 - ) - ensures pts_to_mask #t a2 #p2 s2 m2 -{ - unfold pts_to_mask a1 #p1 s1 m1; - 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)); - fold pts_to_mask a2 #p2 s2 m2; -} - -ghost fn pcm_share u#a (#t: Type u#a) - (a: array t) p s m - (a1: array t) p1 s1 m1 - (a2: array t) p2 s2 m2 - 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 - ) - 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); - 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); - 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); - 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))); - 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))); - fold pts_to_mask a2 #p2 s2 m2; -} - -ghost fn pcm_gather u#a (#t: Type u#a) - (a: array t) p s m - (a1: array t) p1 s1 m1 - (a2: array t) p2 s2 m2 - 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) - ) - requires pts_to_mask a1 #p1 s1 m1 - requires pts_to_mask a2 #p2 s2 m2 - ensures pts_to_mask a #p s m - 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 - ) -{ - unfold pts_to_mask a1 #p1 s1 m1; - unfold pts_to_mask a2 #p2 s2 m2; - 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); - 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); - 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)); - fold pts_to_mask a #p s m; -} - -ghost -fn mask_share u#a (#a: Type u#a) (arr:array a) (#s: Seq.seq a) #p #mask - requires pts_to_mask arr #p s mask - ensures pts_to_mask arr #(p /. 2.0R) s mask - ensures pts_to_mask arr #(p /. 2.0R) s mask -{ - pts_to_mask_props arr; - pcm_share - arr p s mask - arr (p /. 2.0R) s mask - arr (p /. 2.0R) s mask; -} - -[@@allow_ambiguous] -ghost fn mask_gather u#a (#t: Type u#a) (arr: array t) #p1 #p2 #s1 #s2 #mask1 #mask2 - requires pts_to_mask arr #p1 s1 mask1 - requires pts_to_mask arr #p2 s2 mask2 - requires pure (forall i. mask1 i <==> mask2 i) - ensures exists* (v: Seq.seq t). pts_to_mask arr #(p1 +. p2) v mask1 ** - 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)) -{ - mask_mext arr #p2 #s2 mask1; - pts_to_mask_props arr #p1 #s1 #mask1; - pts_to_mask_props arr #p2 #s2 #mask1; - pcm_gather - arr (p1 +. p2) s1 mask1 - 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)); -} - -ghost fn split_mask u#a (#t: Type u#a) (arr: array t) #f #v #mask (pred: nat -> prop) - requires pts_to_mask arr #f v mask - ensures pts_to_mask arr #f v (mask_isect mask pred) - ensures pts_to_mask arr #f v (mask_diff mask pred) -{ - 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); -} - -let mix #t (v1: Seq.seq t) (v2: Seq.seq t { Seq.length v1 == Seq.length v2 }) (mask: nat -> prop) : - GTot (res: Seq.seq t { Seq.length res == Seq.length v1 /\ - (forall (i: nat). i < Seq.length res ==> - (mask i ==> Seq.index res i == Seq.index v1 i) /\ - (~(mask i) ==> Seq.index res i == Seq.index v2 i)) }) = - Seq.init_ghost (Seq.length v1) fun i -> - if IndefiniteDescription.strong_excluded_middle (mask i) then Seq.index v1 i else Seq.index v2 i - -[@@allow_ambiguous] -ghost fn join_mask u#a (#t: Type u#a) (arr: array t) #f #v1 #v2 #mask1 #mask2 - requires pts_to_mask arr #f v1 mask1 - requires pts_to_mask arr #f v2 mask2 - requires pure (forall i. ~(mask1 i /\ mask2 i)) - ensures exists* (v: Seq.seq t). - pts_to_mask arr #f v (fun i -> mask1 i \/ mask2 i) ** - pure (Seq.length v == Seq.length v1 /\ Seq.length v == Seq.length v2 /\ - (forall (i: nat). i < Seq.length v ==> - (mask1 i ==> Seq.index v i == Seq.index v1 i) /\ - (mask2 i ==> Seq.index v i == Seq.index v2 i))) -{ - pts_to_mask_props arr #f #v1 #mask1; - pts_to_mask_props arr #f #v2 #mask2; - let v = mix v1 v2 mask1; - with mask. assert pure (mask == (fun i -> mask1 i \/ mask2 i)); - pcm_gather - arr f v mask - arr f v1 mask1 - arr f v2 mask2; -} - -[@@allow_ambiguous] -ghost fn join_mask' u#a (#t: Type u#a) (arr: array t) #f (#v: erased (Seq.seq t)) #mask1 #mask2 - requires pts_to_mask arr #f v mask1 - requires pts_to_mask arr #f v mask2 - requires pure (forall i. ~(mask1 i /\ mask2 i)) - ensures pts_to_mask arr #f v (fun i -> mask1 i \/ mask2 i) -{ - join_mask arr #f #v #v #mask1 #mask2; - mask_vext arr v; -} - -[@@allow_ambiguous] -ghost -fn pts_to_mask_injective_eq u#a (#a: Type u#a) #p0 #p1 #s0 #s1 #mask0 #mask1 (arr:array a) - preserves pts_to_mask arr #p0 s0 mask0 - preserves pts_to_mask arr #p1 s1 mask1 - ensures pure (Seq.length s0 == Seq.length s1 /\ - (forall (i: nat). i < Seq.length s0 /\ mask0 i /\ mask1 i ==> - Seq.index s0 i == Seq.index s1 i)) -{ - unfold pts_to_mask arr #p0 s0 mask0; - 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); - 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)); - fold pts_to_mask arr #p0 s0 mask0; - fold pts_to_mask arr #p1 s1 mask1; -} - -[@@noextract_to "krml"] -fn mask_read u#a (#t: Type u#a) (a: array t) (i: SZ.t) #p (#s: erased (Seq.seq t) { SZ.v i < Seq.length s }) #mask - preserves pts_to_mask a #p s mask - requires pure (mask (SZ.v i)) - returns res: t - ensures pure (res == Seq.index s (SZ.v i)) -{ - unfold pts_to_mask a #p s mask; - 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))); -} - -[@@noextract_to "krml"] -fn mask_write u#a (#t: Type u#a) (a: array t) (i: SZ.t) (v: t) (#s: erased (Seq.seq t) { SZ.v i < Seq.length s }) #mask - requires pts_to_mask a s mask - requires pure (mask (SZ.v i)) - ensures pts_to_mask a (Seq.upd s (SZ.v i) v) mask -{ - unfold pts_to_mask a s mask; - 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 - ) - _ (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.equal` - mk_carrier' a 1.0R (Seq.upd s (SZ.v i) v) mask - ); - fold pts_to_mask a (Seq.upd s (SZ.v i) v) mask; -} - -[@@noextract_to "krml"] -let sub_impl #t (arr: array t) (i: nat) (j: erased nat { i <= j /\ j <= length arr }) : array t = - { arr with offset = arr.offset + i; length = j - i } - -let gsub #t (arr: array t) (i: nat) (j: nat { i <= j /\ j <= length arr }) : GTot (array t) = - sub_impl arr i j - -let length_gsub #t arr i j = () -let offset_of_gsub #t arr i j = () -let base_of_gsub #t arr i j = () - -ghost fn gsub_intro u#a (#t: Type u#a) (arr: array t) #f #mask (i j: nat) (#v: erased (Seq.seq t) { i <= j /\ j <= Seq.length v }) - requires pts_to_mask arr #f v mask - requires pure (forall (k: nat). mask k /\ k < Seq.length v ==> i <= k /\ k < j) - returns _: squash (length arr == Seq.length v) - ensures pts_to_mask (gsub arr i j) #f (Seq.slice v i j) (fun k -> mask (k + i)) -{ - pts_to_mask_props arr; - pcm_rw - arr f v mask - (gsub arr i j) f (Seq.slice v i j) (fun k -> mask (k + i)); - () -} - -let elim_squash (t: Type u#a { squash' t }) : GTot t = - let h : squash (squash' t) = () in - let h : squash t = IndefiniteDescription.elim_squash h in - IndefiniteDescription.elim_squash h - -ghost fn gsub_elim u#a (#t: Type u#a) (arr: array t) #f (#mask: nat->prop) (i j: nat) - (#v: erased (Seq.seq t) { i <= j /\ j <= length arr }) - requires pts_to_mask (gsub arr i j) #f v mask - returns _: squash (j - i == Seq.length v) - ensures exists* (v': Seq.seq t). - pts_to_mask arr #f v' (fun k -> i <= k /\ k < j /\ mask (k - i)) ** - pure (Seq.length v' == length arr /\ (forall (k:nat). k < j - i ==> Seq.index v k == Seq.index v' (k + i))) -{ - pts_to_mask_props (gsub arr i j); - let dummy = elim_squash t; - let v' = Seq.init_ghost (length arr) (fun k -> - if i <= k && k < j then Seq.index v (k - i) else dummy); - pcm_rw - (gsub arr i j) f v mask - arr f v' (fun k -> i <= k /\ k < j /\ mask (k - i)); - () -} - -[@@noextract_to "krml"] -unobservable -fn sub u#a (#t: Type u#a) (arr: array t) #f #mask (i: SZ.t) (j: erased nat) - (#v: erased (Seq.seq t) { SZ.v i <= j /\ j <= Seq.length (reveal v) }) - requires pts_to_mask arr #f v mask - returns sub: (sub: array t { length arr == Seq.length (reveal v) }) - ensures rewrites_to sub (gsub arr (SZ.v i) j) - ensures pts_to_mask sub #f (Seq.slice v (SZ.v i) j) (fun k -> mask (k + SZ.v i)) - ensures pts_to_mask arr #f v (fun k -> mask k /\ ~(SZ.v i <= k /\ k < j)) -{ - let pred = (fun k -> SZ.v i <= k /\ k < j); - pts_to_mask_props arr; - split_mask arr pred; - gsub_intro arr #f #(mask_isect mask pred) (SZ.v i) j; - mask_mext (gsub arr (SZ.v i) j) (fun k -> mask (k + SZ.v i)); - rewrite each gsub arr (SZ.v i) j as sub_impl arr (SZ.v i) j; - sub_impl arr (SZ.v i) j -} - -[@@allow_ambiguous] -ghost fn return_sub u#a (#t: Type u#a) (arr: array t) #f (#v #vsub: erased (Seq.seq t)) #mask #masksub (#i: nat) (#j: nat { i <= j /\ j <= length arr }) - requires pts_to_mask arr #f v mask - requires pts_to_mask (gsub arr i j) #f vsub masksub - requires pure (forall (k: nat). i <= k /\ k < j ==> ~(mask k)) - ensures exists* v'. pts_to_mask arr #f v' (fun k -> mask k \/ (i <= k /\ k < j /\ masksub (k - i))) - ** pure (Seq.length v == Seq.length v' /\ i + Seq.length vsub == j /\ j <= Seq.length v /\ - (forall (k: nat). k < Seq.length v' ==> - Seq.index v' k == (if i <= k && k < j then Seq.index vsub (k - i) else Seq.index v k))) -{ - gsub_elim arr i j; - join_mask arr; - let v' = Seq.init_ghost (Seq.length v) (fun k -> - if i <= k && k < j then Seq.index vsub (k - i) else Seq.index v k); - mask_ext arr v' (fun k -> mask k \/ (i <= k /\ k < j /\ masksub (k - i))); -} \ No newline at end of file diff --git a/lib/pulse/lib/Pulse.Lib.HigherArray.Core.fsti b/lib/pulse/lib/Pulse.Lib.HigherArray.Core.fsti deleted file mode 100644 index e9d1dc087..000000000 --- a/lib/pulse/lib/Pulse.Lib.HigherArray.Core.fsti +++ /dev/null @@ -1,197 +0,0 @@ -(* - 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.HigherArray.Core -#lang-pulse -open FStar.Tactics.V2 -open Pulse.Lib.Core -open Pulse.Main -open Pulse.Class.PtsTo -open PulseCore.FractionalPermission -open FStar.Ghost -module SZ = FStar.SizeT -open Pulse.Lib.SmallType - -[@@erasable] val base_t : Type0 - -val array ([@@@unused] a:Type u#a) : Type u#0 - -val length (#a:Type) (x:array a) : Ghost nat (requires True) (ensures SZ.fits) -val base_of #t (a: array t) : base_t -val offset_of #t (a: array t) : GTot nat - -type elseq (a:Type) (l:SZ.t) = s:erased (Seq.seq a) { Seq.length s == SZ.v l } - -inline_for_extraction -type larray t (n:nat) = a:array t { length a == n } - -val is_full_array (#a:Type) (x:array a) : prop - -val null #a : array a -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 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))] - -ghost -fn pts_to_mask_len u#a (#t: Type u#a) (a:array t) (#p:perm) (#x:Seq.seq t) #mask - preserves pts_to_mask a #p x mask - ensures pure (length a == Seq.length x) - -ghost -fn pts_to_mask_perm_bound u#a (#t: Type u#a) (arr: array t) #p (#s:Seq.seq t) #mask - preserves pts_to_mask arr #p s mask - requires pure (exists (i: nat). i < Seq.length s /\ mask i) - ensures pure (p <=. 1.0R) - -ghost -fn pts_to_mask_not_null u#a (#a: Type u#a) #p (r:array a) (#v:Seq.seq a) #mask - preserves pts_to_mask r #p v mask - ensures pure (not (is_null r)) - -ghost fn mask_vext u#a (#t: Type u#a) (arr: array t) #f #v v' #mask - requires pts_to_mask arr #f v mask - requires pure (Seq.length v' == Seq.length v /\ - (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 - -ghost fn mask_mext u#a (#t: Type u#a) (arr: array t) #f #v #mask (mask': nat -> prop) - requires pts_to_mask arr #f v mask - requires pure (forall (i: nat). i < Seq.length v ==> (mask i <==> mask' i)) - ensures pts_to_mask arr #f v mask' - -ghost fn mask_ext u#a (#t: Type u#a) (arr: array t) #f #v #mask v' (mask': nat -> prop) - requires pts_to_mask arr #f v mask - requires pure (forall (i: nat). i < Seq.length v ==> (mask i <==> mask' i)) - requires pure (Seq.length v' == Seq.length v /\ - (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' - -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) - -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) - requires pure (is_full_array a) - -ghost -fn mask_share u#a (#a: Type u#a) (arr:array a) (#s: Seq.seq a) #p #mask - requires pts_to_mask arr #p s mask - ensures pts_to_mask arr #(p /. 2.0R) s mask - ensures pts_to_mask arr #(p /. 2.0R) s mask - -[@@allow_ambiguous] -ghost fn mask_gather u#a (#t: Type u#a) (arr: array t) #p1 #p2 #s1 #s2 #mask1 #mask2 - requires pts_to_mask arr #p1 s1 mask1 - requires pts_to_mask arr #p2 s2 mask2 - requires pure (forall i. mask1 i <==> mask2 i) - ensures exists* (v: Seq.seq t). pts_to_mask arr #(p1 +. p2) v mask1 ** - 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)) - -// We need to give names to these combinators, otherwise unfold can't -// distinguish them when we have multiple pts_to_mask resources. -unfold let mask_isect (mask pred: nat -> prop) : nat -> prop = fun i -> mask i /\ pred i -unfold let mask_diff (mask pred: nat -> prop) : nat -> prop = fun i -> mask i /\ ~(pred i) - -ghost fn split_mask u#a (#t: Type u#a) (arr: array t) #f #v #mask (pred: nat -> prop) - requires pts_to_mask arr #f v mask - ensures pts_to_mask arr #f v (mask_isect mask pred) - ensures pts_to_mask arr #f v (mask_diff mask pred) - -[@@allow_ambiguous] -ghost fn join_mask u#a (#t: Type u#a) (arr: array t) #f #v1 #v2 #mask1 #mask2 - requires pts_to_mask arr #f v1 mask1 - requires pts_to_mask arr #f v2 mask2 - requires pure (forall i. ~(mask1 i /\ mask2 i)) - ensures exists* (v: Seq.seq t). - pts_to_mask arr #f v (fun i -> mask1 i \/ mask2 i) ** - pure (Seq.length v == Seq.length v1 /\ Seq.length v == Seq.length v2 /\ - (forall (i: nat). i < Seq.length v ==> - (mask1 i ==> Seq.index v i == Seq.index v1 i) /\ - (mask2 i ==> Seq.index v i == Seq.index v2 i))) - -[@@allow_ambiguous] -ghost fn join_mask' u#a (#t: Type u#a) (arr: array t) #f (#v: erased (Seq.seq t)) #mask1 #mask2 - requires pts_to_mask arr #f v mask1 - requires pts_to_mask arr #f v mask2 - requires pure (forall i. ~(mask1 i /\ mask2 i)) - ensures pts_to_mask arr #f v (fun i -> mask1 i \/ mask2 i) - -[@@allow_ambiguous] -ghost -fn pts_to_mask_injective_eq u#a (#a: Type u#a) #p0 #p1 #s0 #s1 #mask0 #mask1 (arr:array a) - preserves pts_to_mask arr #p0 s0 mask0 - preserves pts_to_mask arr #p1 s1 mask1 - ensures pure (Seq.length s0 == Seq.length s1 /\ - (forall (i: nat). i < Seq.length s0 /\ mask0 i /\ mask1 i ==> - Seq.index s0 i == Seq.index s1 i)) - -fn mask_read u#a (#t: Type u#a) (a: array t) (i: SZ.t) #p (#s: erased (Seq.seq t) { SZ.v i < Seq.length s }) #mask - preserves pts_to_mask a #p s mask - requires pure (mask (SZ.v i)) - returns res: t - ensures pure (res == Seq.index s (SZ.v i)) - -fn mask_write u#a (#t: Type u#a) (a: array t) (i: SZ.t) (v: t) (#s: erased (Seq.seq t) { SZ.v i < Seq.length s }) #mask - requires pts_to_mask a s mask - requires pure (mask (SZ.v i)) - ensures pts_to_mask a (Seq.upd s (SZ.v i) v) mask - -val gsub #t (arr: array t) (i: nat) (j: nat { i <= j /\ j <= length arr }) : GTot (array t) - -val length_gsub #t arr i j : Lemma (length (gsub #t arr i j) == j - i) [SMTPat (length (gsub arr i j))] -val offset_of_gsub #t arr i j : Lemma (offset_of (gsub #t arr i j) == offset_of arr + i) [SMTPat (offset_of (gsub arr i j))] -val base_of_gsub #t arr i j : Lemma (base_of (gsub #t arr i j) == base_of arr) [SMTPat (base_of (gsub arr i j))] - -ghost fn gsub_intro u#a (#t: Type u#a) (arr: array t) #f #mask (i j: nat) (#v: erased (Seq.seq t) { i <= j /\ j <= Seq.length v }) - requires pts_to_mask arr #f v mask - requires pure (forall (k: nat). mask k /\ k < Seq.length v ==> i <= k /\ k < j) - returns _: squash (length arr == Seq.length v) - ensures pts_to_mask (gsub arr i j) #f (Seq.slice v i j) (fun k -> mask (k + i)) - -ghost fn gsub_elim u#a (#t: Type u#a) (arr: array t) #f (#mask: nat->prop) (i j: nat) - (#v: erased (Seq.seq t) { i <= j /\ j <= length arr }) - requires pts_to_mask (gsub arr i j) #f v mask - returns _: squash (j - i == Seq.length v) - ensures exists* (v': Seq.seq t). - pts_to_mask arr #f v' (fun k -> i <= k /\ k < j /\ mask (k - i)) ** - pure (Seq.length v' == length arr /\ (forall (k:nat). k < j - i ==> Seq.index v k == Seq.index v' (k + i))) - -unobservable -fn sub u#a (#t: Type u#a) (arr: array t) #f #mask (i: SZ.t) (j: erased nat) - (#v: erased (Seq.seq t) { SZ.v i <= j /\ j <= Seq.length (reveal v) }) - requires pts_to_mask arr #f v mask - returns sub: (sub: array t { length arr == Seq.length (reveal v) }) - ensures rewrites_to sub (gsub arr (SZ.v i) j) - ensures pts_to_mask sub #f (Seq.slice v (SZ.v i) j) (fun k -> mask (k + SZ.v i)) - ensures pts_to_mask arr #f v (fun k -> mask k /\ ~(SZ.v i <= k /\ k < j)) - -[@@allow_ambiguous] -ghost fn return_sub u#a (#t: Type u#a) (arr: array t) #f (#v #vsub: erased (Seq.seq t)) #mask #masksub (#i: nat) (#j: nat { i <= j /\ j <= length arr }) - requires pts_to_mask arr #f v mask - requires pts_to_mask (gsub arr i j) #f vsub masksub - requires pure (forall (k: nat). i <= k /\ k < j ==> ~(mask k)) - ensures exists* v'. pts_to_mask arr #f v' (fun k -> mask k \/ (i <= k /\ k < j /\ masksub (k - i))) - ** pure (Seq.length v == Seq.length v' /\ i + Seq.length vsub == j /\ j <= Seq.length v /\ - (forall (k: nat). k < Seq.length v' ==> - Seq.index v' k == (if i <= k && k < j then Seq.index vsub (k - i) else Seq.index v k))) \ No newline at end of file diff --git a/lib/pulse/lib/Pulse.Lib.HigherGhostReference.fst b/lib/pulse/lib/Pulse.Lib.HigherGhostReference.fst deleted file mode 100644 index 7b04941ad..000000000 --- a/lib/pulse/lib/Pulse.Lib.HigherGhostReference.fst +++ /dev/null @@ -1,177 +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.Lib.HigherGhostReference -#lang-pulse -open Pulse.Lib.Core -open Pulse.Main -open FStar.PCM -open Pulse.Lib.PCM.Fraction -module T = FStar.Tactics -let ref (a:Type u#1) = ghost_pcm_ref #_ (pcm_frac #a) - -let null #a = null_core_ghost_pcm_ref - -instance non_informative_gref (a:Type u#1) : NonInformative.non_informative (ref a) = { - reveal = (fun x -> Ghost.reveal x) <: NonInformative.revealer (ref a); -} - -let pts_to (#a:Type) (r:ref a) (#[T.exact (`1.0R)] p:perm) (n:a) -= ghost_pcm_pts_to r (Some (n, p)) ** pure (perm_ok p) - -let pts_to_timeless _ _ _ = () - - -ghost -fn full_values_compatible (#a:Type u#1) (x:a) - requires emp - ensures pure (compatible pcm_frac (Some (x, 1.0R)) (Some (x, 1.0R))) -{ - assert pure (FStar.PCM.composable pcm_frac (Some(x, 1.0R)) None); -} - - - -ghost -fn alloc (#a:Type u#1) (x:a) - requires emp - returns r:ref a - ensures pts_to r x -{ - full_values_compatible x; - let r = Pulse.Lib.Core.ghost_alloc #_ #(pcm_frac #a) (Some (x, 1.0R)); - fold (pts_to r #1.0R x); - r -} - - -let read_compat (#a:Type u#1) (x:fractional a) - (v:fractional a { compatible pcm_frac x v }) - : GTot (y:fractional a { compatible pcm_frac y v /\ - FStar.PCM.frame_compatible pcm_frac x v y }) - = x - - -ghost -fn read (#a:Type u#1) (r:ref a) (#n:erased a) (#p:perm) - preserves pts_to r #p n - returns x:erased a - ensures rewrites_to x n -{ - unfold pts_to r #p n; - with w. assert (ghost_pcm_pts_to r w); - let x = Pulse.Lib.Core.ghost_read r w (fun _ -> w); - assert pure (compatible pcm_frac w x); - assert (ghost_pcm_pts_to r w); - fold (pts_to r #p n); - hide (fst (Some?.v x)) -} - - -let ( ! ) #a = read #a - - -ghost -fn ( := ) (#a:Type u#1) (r:ref a) (x:erased a) (#n:erased a) - requires pts_to r #1.0R n - ensures pts_to r #1.0R x -{ - unfold pts_to r #1.0R n; - with w. assert (ghost_pcm_pts_to r w); - Pulse.Lib.Core.ghost_write r _ _ (mk_frame_preserving_upd n x); - fold pts_to r #1.0R x; -} - -let write = ( := ) - - -ghost -fn free #a (r:ref a) (#n:erased a) - requires pts_to r #1.0R n - ensures emp -{ - unfold pts_to r #1.0R n; - Pulse.Lib.Core.ghost_write r _ _ (mk_frame_preserving_upd_none n); - Pulse.Lib.Core.drop_ _; -} - - - -ghost -fn share #a (r:ref a) (#v:erased a) (#p:perm) - requires pts_to r #p v - ensures pts_to r #(p /. 2.0R) v ** pts_to r #(p /. 2.0R) v -{ - unfold pts_to r #p v; - rewrite ghost_pcm_pts_to r (Some (reveal v, p)) - as ghost_pcm_pts_to r (Some (reveal v, p /. 2.0R) `op pcm_frac` Some(reveal v, p /. 2.0R)); - Pulse.Lib.Core.ghost_share r (Some (reveal v, p /. 2.0R)) _; //writing an underscore for the first arg also causes a crash - fold (pts_to r #(p /. 2.0R) v); - fold (pts_to r #(p /. 2.0R) v); -} - - - -ghost -fn gather #a (r:ref a) (#x0 #x1:erased a) (#p0 #p1:perm) - requires pts_to r #p0 x0 ** pts_to r #p1 x1 - ensures pts_to r #(p0 +. p1) x0 ** pure (x0 == x1) -{ - unfold pts_to r #p0 x0; - unfold pts_to r #p1 x1; - Pulse.Lib.Core.ghost_gather r (Some (reveal x0, p0)) (Some (reveal x1, p1)); - fold (pts_to r #(p0 +. p1) x0) -} - - -ghost -fn pts_to_injective_eq - (#a:Type) - (#p0 #p1:perm) - (#v0 #v1:a) - (r:ref a) - requires pts_to r #p0 v0 ** pts_to r #p1 v1 - ensures pts_to r #p0 v0 ** pts_to r #p1 v1 ** pure (v0 == v1) -{ - unfold pts_to r #p0 v0; - unfold pts_to r #p1 v1; - Pulse.Lib.Core.ghost_gather r (Some (v0, p0)) (Some (v1, p1)); - Pulse.Lib.Core.ghost_share r (Some (v0, p0)) (Some (v1, p1)); - fold pts_to r #p0 v0; - fold pts_to r #p1 v1; -} - - - -ghost -fn pts_to_perm_bound (#a:_) (#p:_) (r:ref a) (#v:a) - requires pts_to r #p v - ensures pts_to r #p v ** pure (p <=. 1.0R) -{ - unfold pts_to r #p v; - fold pts_to r #p v; -} - - -ghost -fn pts_to_not_null #a (#p:_) (r:ref a) (#v:a) - preserves r |-> Frac p v - ensures pure (r =!= null) -{ - unfold pts_to r #p v; - ghost_pts_to_not_null r _; - fold pts_to r #p v; -} \ No newline at end of file diff --git a/lib/pulse/lib/Pulse.Lib.HigherGhostReference.fsti b/lib/pulse/lib/Pulse.Lib.HigherGhostReference.fsti deleted file mode 100644 index a2a559a3b..000000000 --- a/lib/pulse/lib/Pulse.Lib.HigherGhostReference.fsti +++ /dev/null @@ -1,112 +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.Lib.HigherGhostReference -#lang-pulse -open FStar.Tactics -open Pulse.Lib.Core -open Pulse.Main -open PulseCore.FractionalPermission -open FStar.Ghost -open Pulse.Class.PtsTo - -[@@erasable] -val ref ([@@@unused] a:Type u#1) : Type u#0 - -val null #a : ref a - -instance val non_informative_gref (a:Type u#1) - : NonInformative.non_informative (ref a) - -val pts_to - (#a:Type) - ([@@@mkey] r:ref a) - (#[exact (`1.0R)] p:perm) - (n:a) -: slprop - -[@@pulse_unfold] -instance has_pts_to_ref (a:Type) : has_pts_to (ref a) a = { - pts_to = (fun r #f v -> pts_to r #f v); -} - -val pts_to_timeless (#a:Type) (r:ref a) (p:perm) (n:a) - : Lemma (timeless (pts_to r #p n)) - -ghost -fn alloc (#a:Type) (x:a) - returns r : ref a - ensures r |-> x - -ghost -fn read (#a:Type) (r:ref a) (#n:erased a) (#p:perm) - preserves r |-> Frac p n - returns x : erased a - ensures rewrites_to x n - -(* alias for read *) -ghost -fn ( ! ) (#a:Type) (r:ref a) (#n:erased a) (#p:perm) - preserves pts_to r #p n - returns x : erased a - ensures rewrites_to x n - -ghost -fn write (#a:Type) (r:ref a) (x:erased a) (#n:erased a) - requires r |-> n - ensures r |-> x - -(* alias for write *) -ghost -fn ( := ) (#a:Type) (r:ref a) (x:erased a) (#n:erased a) - requires r |-> n - ensures r |-> x - -ghost -fn free (#a:Type) (r:ref a) (#n:erased a) - requires pts_to r n - ensures emp - -ghost -fn share (#a:Type) (r:ref a) (#v:erased a) (#p:perm) - requires r |-> Frac p v - ensures (r |-> Frac (p /. 2.0R) v) ** - (r |-> Frac (p /. 2.0R) v) - -[@@allow_ambiguous] -ghost -fn gather (#a:Type) (r:ref a) (#x0 #x1:erased a) (#p0 #p1:perm) - requires (r |-> Frac p0 x0) ** (r |-> Frac p1 x1) - ensures (r |-> Frac (p0 +. p1) x0) ** pure (x0 == x1) - -[@@allow_ambiguous] -ghost -fn pts_to_injective_eq (#a:_) - (#p #q:_) - (#v0 #v1:a) - (r:ref a) - requires (r |-> Frac p v0) ** (r |-> Frac q v1) - ensures (r |-> Frac p v0) ** (r |-> Frac q v1) ** pure (v0 == v1) - -ghost -fn pts_to_perm_bound (#a:_) (#p:_) (r:ref a) (#v:a) - requires r |-> Frac p v - ensures (r |-> Frac p v) ** pure (p <=. 1.0R) - -ghost -fn pts_to_not_null #a (#p:_) (r:ref a) (#v:a) - preserves r |-> Frac p v - ensures pure (r =!= null) \ No newline at end of file diff --git a/lib/pulse/lib/Pulse.Lib.HigherReference.fst b/lib/pulse/lib/Pulse.Lib.HigherReference.fst deleted file mode 100644 index 98fa3aa86..000000000 --- a/lib/pulse/lib/Pulse.Lib.HigherReference.fst +++ /dev/null @@ -1,222 +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.Lib.HigherReference -#lang-pulse -open Pulse.Lib.Core -module A = Pulse.Lib.HigherArray - -let ref a = A.array a - -let null #a : ref a = A.null - -let is_null #a (r : ref a) - : b:bool{b <==> r == null #a} -= A.is_null r - -let singleton #a (x:a) : Seq.seq a = Seq.create 1 x -let singleton_inj #a (x: a) : Lemma (Seq.index (singleton x) 0 == x) [SMTPat (singleton x)] = () -let upd_singleton #a (x y: a) : - Lemma (Seq.upd (singleton x) 0 y == singleton y) - [SMTPat (Seq.upd (singleton x) 0 y)] = - assert Seq.equal (Seq.upd (singleton x) 0 y) (singleton y) - -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 pts_to_timeless _ _ _ = () - -let is_full_ref = A.is_full_array - -fn alloc u#a (#a: Type u#a) {| small_type u#a |} (x:a) - returns r:ref a - ensures pts_to r x - ensures pure (is_full_ref r) -{ - let r = A.alloc x 1sz; - fold (pts_to r #1.0R x); - r -} - -fn read u#a (#a: Type u#a) (r:ref a) (#n:erased a) (#p:perm) - preserves r |-> Frac p n - returns x : a - ensures rewrites_to x n -{ - unfold pts_to r #p n; - let x = A.(r.(0sz)); - fold (pts_to r #p n); - x -} - -inline_for_extraction -let ( ! ) #a = read #a - -fn write u#a (#a: Type u#a) (r:ref a) (x:a) (#n:erased a) - requires r |-> n - ensures r |-> x -{ - unfold pts_to r #1.0R n; - A.(r.(0sz) <- x); - fold pts_to r #1.0R x; -} - -inline_for_extraction -let ( := ) #a = write #a - - -fn free u#a (#a: Type u#a) (r:ref a) (#n:erased a) - requires pts_to r #1.0R n - requires pure (is_full_ref r) -{ - unfold pts_to r #1.0R n; - A.free r; -} - -ghost -fn share u#a (#a: Type u#a) (r:ref a) (#v:erased a) (#p:perm) - requires pts_to r #p v - ensures pts_to r #(p /. 2.0R) v ** pts_to r #(p /. 2.0R) v -{ - unfold pts_to r #p v; - A.share r; - fold (pts_to r #(p /. 2.0R) v); - fold (pts_to r #(p /. 2.0R) v); -} - -ghost -fn gather u#a (#a: Type u#a) (r:ref a) (#x0 #x1:erased a) (#p0 #p1:perm) - requires pts_to r #p0 x0 ** pts_to r #p1 x1 - ensures pts_to r #(p0 +. p1) x0 ** pure (x0 == x1) -{ - unfold pts_to r #p0 x0; - unfold pts_to r #p1 x1; - A.gather r; - fold (pts_to r #(p0 +. p1) x0) -} - -fn with_local u#a u#b - (#a:Type u#a) {| small_type u#a |} - (init:a) - (#pre:slprop) - (#ret_t:Type u#b) - (#post:ret_t -> slprop) - (body:(r:ref a) -> stt ret_t (pre ** pts_to r init) - (fun v -> post v ** (exists* (x:a). pts_to r x))) - : stt ret_t pre (fun r -> post r) = -{ - let x = alloc init; - let r = body x; - free x; - r -} - -ghost -fn pts_to_injective_eq - u#a (#a: Type u#a) - (#p0 #p1:perm) - (#v0 #v1:a) - (r:ref a) - requires pts_to r #p0 v0 ** pts_to r #p1 v1 - ensures (pts_to r #p0 v0 ** pts_to r #p1 v1) ** pure (v0 == v1) -{ - unfold pts_to r #p0 v0; - unfold pts_to r #p1 v1; - A.pts_to_injective_eq r; - fold pts_to r #p0 v0; - fold pts_to r #p1 v1; -} - - -ghost -fn pts_to_perm_bound u#a (#a: Type u#a) (#p:_) (r:ref a) (#v:a) - requires pts_to r #p v - ensures pts_to r #p v ** pure (p <=. 1.0R) -{ - unfold pts_to r #p v; - A.pts_to_perm_bound r; - fold pts_to r #p v; -} - -ghost -fn pts_to_not_null u#a (#a: Type u#a) (#p:_) (r:ref a) (#v:a) - preserves r |-> Frac p v - ensures pure (not (is_null #a r)) -{ - unfold pts_to r #p v; - A.pts_to_not_null r; - fold pts_to r #p v; -} - -let to_array_ghost r = r - -unobservable -fn to_array u#a (#a: Type u#a) (r: ref a) #p (#v: erased a) - requires r |-> Frac p v - returns arr: array a - ensures rewrites_to arr (to_array_ghost r) - ensures arr |-> Frac p (seq![reveal v]) - ensures pure (length arr == 1) -{ - unfold pts_to r #p v; - pts_to_len r; - assert pure (Seq.equal seq![reveal v] (singleton (reveal v))); - r -} - -ghost -fn return_to_array u#a (#a: Type u#a) (r: ref a) #p (#v: Seq.seq a) - requires to_array_ghost r |-> Frac p v - requires pure (length (to_array_ghost r) == 1) - returns _: squash (Seq.length v == 1) - ensures r |-> Frac p (Seq.index v 0) -{ - pts_to_len r; - assert pure (singleton (Seq.Base.index v 0) `Seq.equal` v); - fold pts_to r #p (Seq.index v 0); -} - -let array_at_ghost arr i = gsub arr i (i+1) - -unobservable -fn array_at u#a (#a: Type u#a) (arr: array a) (i: SizeT.t) #p (#v: erased (Seq.seq a) { SizeT.v i < length arr /\ length arr == Seq.length v }) #mask - requires pts_to_mask arr #p v mask - requires pure (mask (SizeT.v i)) - returns r: ref a - ensures rewrites_to r (array_at_ghost arr (SizeT.v i)) - ensures r |-> Frac p (Seq.index v (SizeT.v i)) - ensures pts_to_mask arr #p v (fun k -> mask k /\ k <> SizeT.v i) -{ - let res = sub arr i (SizeT.v i + 1); - mask_ext res (singleton (Seq.index v (SizeT.v i))) (fun _ -> True); - from_mask res; - fold pts_to res #p (Seq.index v (SizeT.v i)); - mask_mext arr (fun k -> mask k /\ k <> SizeT.v i); - res -} - -ghost -fn return_array_at u#a (#a: Type u#a) (arr: array a) (i: nat) (#p: perm) (#v: a) (#v': Seq.seq a { i < length arr /\ length arr == Seq.length v' }) (#mask: nat->prop) - requires array_at_ghost arr i |-> Frac p v - requires pts_to_mask arr #p v' mask - requires pure (~(mask i)) - ensures pts_to_mask arr #p (Seq.upd v' i v) (fun k -> mask k \/ k == i) -{ - unfold pts_to (array_at_ghost arr i) #p v; - to_mask (array_at_ghost arr i); - gsub_elim arr i (i+1); - join_mask arr; - mask_ext arr (Seq.upd v' i v) (fun k -> mask k \/ k == i); -} diff --git a/lib/pulse/lib/Pulse.Lib.HigherReference.fsti b/lib/pulse/lib/Pulse.Lib.HigherReference.fsti deleted file mode 100644 index af2a413a0..000000000 --- a/lib/pulse/lib/Pulse.Lib.HigherReference.fsti +++ /dev/null @@ -1,153 +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.Lib.HigherReference -#lang-pulse -open Pulse.Main -open Pulse.Lib.Core -open PulseCore.FractionalPermission -open FStar.Ghost -open Pulse.Class.PtsTo -open Pulse.Lib.HigherArray -open Pulse.Lib.SmallType -module T = FStar.Tactics -val ref ([@@@unused]a:Type) : Type0 - -val null #a : ref a - -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 - -[@@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); -} - -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))] - -val is_full_ref #a (x: ref a) : prop - -[@@deprecated "HigherReference.alloc is unsound; only use for model implementations"] -fn alloc u#a (#a: Type u#a) {| small_type u#a |} (x:a) - returns r : ref a - ensures r |-> x - ensures pure (is_full_ref r) - -fn read u#a (#a: Type u#a) (r:ref a) (#n:erased a) (#p:perm) - preserves r |-> Frac p n - returns x : a - ensures rewrites_to x n - -(* alias for read *) -inline_for_extraction -fn ( ! ) u#a (#a: Type u#a) (r:ref a) (#n:erased a) (#p:perm) - preserves r |-> Frac p n - returns x : a - ensures rewrites_to x n - -fn write u#a (#a: Type u#a) (r:ref a) (x:a) (#n:erased a) - requires r |-> n - ensures r |-> x - -(* alias for write *) -inline_for_extraction -fn ( := ) u#a (#a: Type u#a) (r:ref a) (x:a) (#n:erased a) - requires r |-> n - ensures r |-> x - -[@@deprecated "HigherReference.free is unsound; only use for model implementations"] -fn free u#a (#a: Type u#a) (r:ref a) (#n:erased a) - requires pts_to r n - requires pure (is_full_ref r) - -ghost -fn share u#a (#a: Type u#a) (r:ref a) (#v:erased a) (#p:perm) - requires r |-> Frac p v - ensures (r |-> Frac (p /. 2.0R) v) ** - (r |-> Frac (p /. 2.0R) v) - -[@@allow_ambiguous] -ghost -fn gather u#a (#a: Type u#a) (r:ref a) (#x0 #x1:erased a) (#p0 #p1:perm) - requires (r |-> Frac p0 x0) ** (r |-> Frac p1 x1) - ensures (r |-> Frac (p0 +. p1) x0) ** pure (x0 == x1) - -val with_local - (#a:Type u#a) {| small_type u#a |} - (init:a) - (#pre:slprop) - (#ret_t:Type u#b) - (#post:ret_t -> slprop) - (body:(r:ref a) -> stt ret_t (pre ** pts_to r init) - (fun v -> post v ** (exists* (x:a). pts_to r x))) - : stt ret_t pre (fun r -> post r) - -[@@allow_ambiguous] -ghost -fn pts_to_injective_eq u#a (#a: Type u#a) - (#p #q:_) - (#v0 #v1:a) - (r:ref a) - preserves (r |-> Frac p v0) ** (r |-> Frac q v1) - ensures pure (v0 == v1) - -ghost -fn pts_to_perm_bound u#a (#a: Type u#a) (#p:_) (r:ref a) (#v:a) - preserves r |-> Frac p v - ensures pure (p <=. 1.0R) - -ghost -fn pts_to_not_null u#a (#a: Type u#a) (#p:_) (r:ref a) (#v:a) - preserves r |-> Frac p v - ensures pure (not (is_null #a r)) - -val to_array_ghost #a (r: ref a) : GTot (array a) - -unobservable -fn to_array u#a (#a: Type u#a) (r: ref a) #p (#v: erased a) - requires r |-> Frac p v - returns arr: array a - ensures rewrites_to arr (to_array_ghost r) - ensures arr |-> Frac p (seq![reveal v]) - ensures pure (length arr == 1) - -ghost -fn return_to_array u#a (#a: Type u#a) (r: ref a) #p (#v: Seq.seq a) - requires to_array_ghost r |-> Frac p v - requires pure (length (to_array_ghost r) == 1) - returns _: squash (Seq.length v == 1) - ensures r |-> Frac p (Seq.index v 0) - -val array_at_ghost (#a: Type u#a) (arr: array a) (i: nat { i < length arr }) : GTot (r:ref a { to_array_ghost r == gsub arr i (i+1) }) - -unobservable -fn array_at u#a (#a: Type u#a) (arr: array a) (i: SizeT.t) #p (#v: erased (Seq.seq a) { SizeT.v i < length arr /\ length arr == Seq.length v }) #mask - requires pts_to_mask arr #p v mask - requires pure (mask (SizeT.v i)) - returns r: ref a - ensures rewrites_to r (array_at_ghost arr (SizeT.v i)) - ensures r |-> Frac p (Seq.index v (SizeT.v i)) - ensures pts_to_mask arr #p v (fun k -> mask k /\ k <> SizeT.v i) - -ghost -fn return_array_at u#a (#a: Type u#a) (arr: array a) (i: nat) (#p: perm) (#v: a) (#v': Seq.seq a { i < length arr /\ length arr == Seq.length v' }) (#mask: nat->prop) - requires array_at_ghost arr i |-> Frac p v - requires pts_to_mask arr #p v' mask - requires pure (~(mask i)) - ensures pts_to_mask arr #p (Seq.upd v' i v) (fun k -> mask k \/ k == i) \ No newline at end of file diff --git a/lib/pulse/lib/Pulse.Lib.InsertionSort.fst b/lib/pulse/lib/Pulse.Lib.InsertionSort.fst index 8fac39ad1..16fb5e267 100644 --- a/lib/pulse/lib/Pulse.Lib.InsertionSort.fst +++ b/lib/pulse/lib/Pulse.Lib.InsertionSort.fst @@ -57,8 +57,8 @@ let sorted_concat (ensures sorted (Seq.append s0 s1)) = () -fn op_Array_Assignment - (#t: Type) +fn op_Array_Assignment u#a + (#t: Type u#a) (a: array t) (i: SZ.t) (v: t) @@ -134,8 +134,8 @@ let step_outer_invariant #pop-options -fn insertion_sort - (#t:Type) +fn insertion_sort u#a + (#t:Type u#a) {| total_order t |} (a:A.array t) (len:SZ.t) diff --git a/lib/pulse/lib/Pulse.Lib.InsertionSort.fsti b/lib/pulse/lib/Pulse.Lib.InsertionSort.fsti index 89161725f..df327dce2 100644 --- a/lib/pulse/lib/Pulse.Lib.InsertionSort.fsti +++ b/lib/pulse/lib/Pulse.Lib.InsertionSort.fsti @@ -26,8 +26,8 @@ let sorted = forall (i j:nat).{:pattern (Seq.index s i); (Seq.index s j)} i <= j /\ j < Seq.length s ==> Seq.index s i <=? Seq.index s j -fn insertion_sort - (#t:Type) +fn insertion_sort u#a + (#t:Type u#a) {| total_order t |} (a:A.array t) (len:SZ.t) diff --git a/lib/pulse/lib/Pulse.Lib.SmallType.PCM.fst b/lib/pulse/lib/Pulse.Lib.PCMReference.fst similarity index 71% rename from lib/pulse/lib/Pulse.Lib.SmallType.PCM.fst rename to lib/pulse/lib/Pulse.Lib.PCMReference.fst index e6c7dcd2f..95ede7f31 100644 --- a/lib/pulse/lib/Pulse.Lib.SmallType.PCM.fst +++ b/lib/pulse/lib/Pulse.Lib.PCMReference.fst @@ -13,10 +13,9 @@ See the License for the specific language governing permissions and limitations under the License. *) -module Pulse.Lib.SmallType.PCM -open Pulse.Lib.SmallType +module Pulse.Lib.PCMReference open Pulse.Lib.Core -module C = Pulse.Lib.Core +module C = Pulse.Lib.Core.Refs module U = Pulse.Lib.Raise open Pulse.Main open FStar.PCM @@ -25,16 +24,20 @@ open Pulse.Lib.PCM.Raise open Pulse.Lib.WithPure #lang-pulse +let core_pcm_ref = C.core_pcm_ref +let null_core_pcm_ref = C.null_core_pcm_ref +let is_null_core_pcm_ref = C.is_null_core_pcm_ref + let small_token (inst: small_type u#a) = emp [@@pulse_unfold] let pcm_pts_to (#a:Type u#a) (#p:pcm a) ([@@@mkey] r:pcm_ref p) (v:a) : slprop = - exists* (inst: small_type u#a). big_pcm_pts_to #_ #(raise p) r (U.raise_val v) ** small_token inst + exists* (inst: small_type u#a). C.pcm_pts_to #_ #(raise p) r (U.raise_val v) ** small_token inst let timeless_pcm_pts_to #a #p r v = assert_norm (pcm_pts_to r v == op_exists_Star fun (inst: small_type u#a) -> - big_pcm_pts_to #_ #(raise p) r (U.raise_val v) ** small_token inst) + C.pcm_pts_to #_ #(raise p) r (U.raise_val v) ** small_token inst) 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 @@ -48,16 +51,16 @@ ghost fn pts_to_not_null u#a (#a:Type u#a) (#p:FStar.PCM.pcm a) (r:pcm_ref p) (v preserves pcm_pts_to r v ensures pure (not (is_pcm_ref_null r)) { - big_pts_to_not_null _ _; + C.pts_to_not_null _ _; () } -fn alloc u#a (#a:Type u#a) {| inst: small_type u#a |} (#pcm:pcm a) (x:a{pcm.refine x}) +fn alloc u#a (#a:Type u#a) (#pcm:pcm a) {| inst: small_type u#a |} (x:a{pcm.refine x}) returns r: pcm_ref pcm ensures pcm_pts_to r x { fold small_token u#a inst; - big_alloc #(U.raise_t a) #(raise pcm) (U.raise_val x); + C.alloc #(U.raise_t a) #(raise pcm) (U.raise_val x); } fn read u#a (#a:Type u#a) (#p:pcm a) (r:pcm_ref p) (x:erased a) @@ -67,7 +70,7 @@ fn read u#a (#a:Type u#a) (#p:pcm a) (r:pcm_ref p) (x:erased a) ensures pcm_pts_to r (f v) { let inst = pts_to_small r _; - U.downgrade_val (big_read #(U.raise_t a) #(raise p) r (hide (U.raise_val (reveal x))) (raise_refine p x f)); + U.downgrade_val (C.read #(U.raise_t a) #(raise p) r (hide (U.raise_val (reveal x))) (raise_refine p x f)); } fn write u#a (#a:Type u#a) (#p:pcm a) (r:pcm_ref p) (x y:erased a) @@ -76,7 +79,7 @@ fn write u#a (#a:Type u#a) (#p:pcm a) (r:pcm_ref p) (x y:erased a) ensures pcm_pts_to r y { let inst = pts_to_small r _; - big_write #(U.raise_t a) #(raise p) r (hide (U.raise_val (reveal x))) (hide (U.raise_val (reveal y))) + C.write #(U.raise_t a) #(raise p) r (hide (U.raise_val (reveal x))) (hide (U.raise_val (reveal y))) (raise_upd f) } @@ -88,7 +91,7 @@ ghost fn share u#a (#a:Type u#a) (#pcm:pcm a) (r:pcm_ref pcm) { let inst = pts_to_small r _; fold small_token inst; - big_share #(U.raise_t a) #(raise pcm) r (U.raise_val v0) (U.raise_val v1); + C.share #(U.raise_t a) #(raise pcm) r (U.raise_val v0) (U.raise_val v1); } [@@allow_ambiguous] @@ -106,7 +109,7 @@ ghost fn gather u#a (#a:Type u#a) (#pcm:pcm a) (r:pcm_ref pcm) (v0:a) (v1:a) ensures pcm_pts_to r (op pcm v0 v1) { let inst = pts_to_small r v0; - with inst'. assert big_pcm_pts_to #_ #(raise #a #inst' pcm) r (U.raise_val #a #inst' v1); + with inst'. assert C.pcm_pts_to #_ #(raise #a #inst' pcm) r (U.raise_val #a #inst' v1); drop_amb (small_token u#a inst'); - big_gather #(U.raise_t #inst a) #(raise #a #inst pcm) r (U.raise_val #a #inst v0) (U.raise_val #a #inst v1); + C.gather #(U.raise_t #inst a) #(raise #a #inst pcm) r (U.raise_val #a #inst v0) (U.raise_val #a #inst v1); } \ No newline at end of file diff --git a/lib/pulse/lib/Pulse.Lib.SmallType.PCM.fsti b/lib/pulse/lib/Pulse.Lib.PCMReference.fsti similarity index 81% rename from lib/pulse/lib/Pulse.Lib.SmallType.PCM.fsti rename to lib/pulse/lib/Pulse.Lib.PCMReference.fsti index 869dbd2a6..8011a365a 100644 --- a/lib/pulse/lib/Pulse.Lib.SmallType.PCM.fsti +++ b/lib/pulse/lib/Pulse.Lib.PCMReference.fsti @@ -13,7 +13,7 @@ See the License for the specific language governing permissions and limitations under the License. *) -module Pulse.Lib.SmallType.PCM +module Pulse.Lib.PCMReference open Pulse.Lib.SmallType open Pulse.Lib.Core open Pulse.Main @@ -21,6 +21,18 @@ open FStar.PCM open FStar.Ghost #lang-pulse +val core_pcm_ref : Type0 +val null_core_pcm_ref : core_pcm_ref +val is_null_core_pcm_ref (r: core_pcm_ref) : + b:bool { b <==> r == null_core_pcm_ref } + +let pcm_ref (#a: Type u#a) (p: pcm a) : Type0 = core_pcm_ref + +let pcm_ref_null #a (p:pcm a) : pcm_ref p = null_core_pcm_ref +let is_pcm_ref_null #a (#p: pcm a) (r: pcm_ref p) : + b:bool { b <==> r == pcm_ref_null p } = + is_null_core_pcm_ref r + 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) @@ -34,7 +46,7 @@ ghost fn pts_to_not_null u#a (#a:Type u#a) (#p:FStar.PCM.pcm a) (r:pcm_ref p) (v preserves pcm_pts_to r v ensures pure (not (is_pcm_ref_null r)) -fn alloc u#a (#a:Type u#a) {| small_type u#a |} (#pcm:pcm a) (x:a{pcm.refine x}) +fn alloc u#a (#a:Type u#a) (#pcm:pcm a) {| small_type u#a |} (x:a{pcm.refine x}) returns r: pcm_ref pcm ensures pcm_pts_to r x diff --git a/lib/pulse/lib/Pulse.Lib.Pervasives.fst b/lib/pulse/lib/Pulse.Lib.Pervasives.fst index 03f4ad27a..ad451fb59 100644 --- a/lib/pulse/lib/Pulse.Lib.Pervasives.fst +++ b/lib/pulse/lib/Pulse.Lib.Pervasives.fst @@ -25,6 +25,7 @@ include Pulse.Lib.Primitives // TODO: what if we want to support several archite include Pulse.Class.PtsTo include Pulse.Class.Duplicable include Pulse.Class.Introducable { intro } +include Pulse.Lib.SmallType { small_type } include PulseCore.FractionalPermission include PulseCore.Observability include FStar.Ghost @@ -68,7 +69,7 @@ let inames_join_self (is1 : inames) // Native extraction in the Rust backend // -fn ref_apply (#a #b:Type) (r:ref (a -> b)) (x:a) (#f:erased (a -> b)) +fn ref_apply u#a u#b (#a: Type u#a) (#b:Type u#b) (r:ref (a -> b)) (x:a) (#f:erased (a -> b)) requires pts_to r f returns y:b ensures pts_to r f ** pure (y == (reveal f) x) diff --git a/lib/pulse/lib/Pulse.Lib.Reference.fst b/lib/pulse/lib/Pulse.Lib.Reference.fst index 316b47077..9c727f145 100644 --- a/lib/pulse/lib/Pulse.Lib.Reference.fst +++ b/lib/pulse/lib/Pulse.Lib.Reference.fst @@ -17,58 +17,217 @@ module Pulse.Lib.Reference #lang-pulse open Pulse.Lib.Core -open Pulse.Main -module H = Pulse.Lib.HigherReference -friend Pulse.Lib.Array.Core -inline_for_extraction -let ref a = H.ref a +module A = Pulse.Lib.Array.Basic -inline_for_extraction -let null (#a:Type u#0) : ref a = H.null +let ref a = A.array a + +let null #a : ref a = A.null -inline_for_extraction let is_null #a (r : ref a) : b:bool{b <==> r == null #a} -= H.is_null r += A.is_null r -let pts_to r = H.pts_to r +let singleton #a (x:a) : Seq.seq a = Seq.create 1 x +let singleton_inj #a (x: a) : Lemma (Seq.index (singleton x) 0 == x) [SMTPat (singleton x)] = () +let upd_singleton #a (x y: a) : + Lemma (Seq.upd (singleton x) 0 y == singleton y) + [SMTPat (Seq.upd (singleton x) 0 y)] = + assert Seq.equal (Seq.upd (singleton x) 0 y) (singleton y) -let pts_to_timeless r p x = () +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 pts_to_timeless _ _ _ = () -let is_full_ref r = H.is_full_ref r +let is_full_ref = A.is_full_array -inline_for_extraction let alloc v = H.alloc v -inline_for_extraction let read r = H.read r -inline_for_extraction let op_Bang = read -inline_for_extraction let write r = H.write r -inline_for_extraction let op_Colon_Equals = write -inline_for_extraction let free r = H.free r +fn alloc u#a (#a: Type u#a) {| small_type u#a |} (x:a) + returns r:ref a + ensures pts_to r x + ensures pure (is_full_ref r) +{ + let r = A.alloc x 1sz; + fold (pts_to r #1.0R x); + r +} -let share r = H.share r -let gather r = H.gather r +fn read u#a (#a: Type u#a) (r:ref a) (#n:erased a) (#p:perm) + preserves r |-> Frac p n + returns x : a + ensures rewrites_to x n +{ + unfold pts_to r #p n; + let x = A.(r.(0sz)); + fold (pts_to r #p n); + x +} +inline_for_extraction +let ( ! ) #a = read #a -let with_local init = H.with_local init +fn write u#a (#a: Type u#a) (r:ref a) (x:a) (#n:erased a) + requires r |-> n + ensures r |-> x +{ + unfold pts_to r #1.0R n; + A.(r.(0sz) <- x); + fold pts_to r #1.0R x; +} +inline_for_extraction +let ( := ) #a = write #a -let pts_to_injective_eq r = H.pts_to_injective_eq r -let pts_to_perm_bound r = H.pts_to_perm_bound r -let pts_to_not_null r = H.pts_to_not_null r -fn replace (#a:Type0) (r:ref a) (x:a) (#v:erased a) - requires pts_to r v - returns y:a - ensures pts_to r x ** pure (y == reveal v) +fn free u#a (#a: Type u#a) (r:ref a) (#n:erased a) + requires pts_to r #1.0R n + requires pure (is_full_ref r) { - let y = !r; - r := x; - y + unfold pts_to r #1.0R n; + A.free r; +} + +ghost +fn share u#a (#a: Type u#a) (r:ref a) (#v:erased a) (#p:perm) + requires pts_to r #p v + ensures pts_to r #(p /. 2.0R) v ** pts_to r #(p /. 2.0R) v +{ + unfold pts_to r #p v; + A.share r; + fold (pts_to r #(p /. 2.0R) v); + fold (pts_to r #(p /. 2.0R) v); +} + +ghost +fn gather u#a (#a: Type u#a) (r:ref a) (#x0 #x1:erased a) (#p0 #p1:perm) + requires pts_to r #p0 x0 ** pts_to r #p1 x1 + ensures pts_to r #(p0 +. p1) x0 ** pure (x0 == x1) +{ + unfold pts_to r #p0 x0; + unfold pts_to r #p1 x1; + A.gather r; + fold (pts_to r #(p0 +. p1) x0) +} + +fn with_local u#a u#b + (#a:Type u#a) {| small_type u#a |} + (init:a) + (#pre:slprop) + (#ret_t:Type u#b) + (#post:ret_t -> slprop) + (body:(r:ref a) -> stt ret_t (pre ** pts_to r init) + (fun v -> post v ** (exists* (x:a). pts_to r x))) + : stt ret_t pre (fun r -> post r) = +{ + let x = alloc init; + let r = body x; + free x; + r +} + +ghost +fn pts_to_injective_eq + u#a (#a: Type u#a) + (#p0 #p1:perm) + (#v0 #v1:a) + (r:ref a) + requires pts_to r #p0 v0 ** pts_to r #p1 v1 + ensures (pts_to r #p0 v0 ** pts_to r #p1 v1) ** pure (v0 == v1) +{ + unfold pts_to r #p0 v0; + unfold pts_to r #p1 v1; + A.pts_to_injective_eq r; + fold pts_to r #p0 v0; + fold pts_to r #p1 v1; } -let to_array_ghost r = H.to_array_ghost r -inline_for_extraction let to_array r = H.to_array r -let return_to_array r = H.return_to_array r -let array_at_ghost arr i = H.array_at_ghost arr i -inline_for_extraction let array_at arr = H.array_at arr -let return_array_at arr = H.return_array_at arr +ghost +fn pts_to_perm_bound u#a (#a: Type u#a) (#p:_) (r:ref a) (#v:a) + requires pts_to r #p v + ensures pts_to r #p v ** pure (p <=. 1.0R) +{ + unfold pts_to r #p v; + A.pts_to_perm_bound r; + fold pts_to r #p v; +} + +ghost +fn pts_to_not_null u#a (#a: Type u#a) (#p:_) (r:ref a) (#v:a) + preserves r |-> Frac p v + ensures pure (not (is_null #a r)) +{ + unfold pts_to r #p v; + A.pts_to_not_null r; + fold pts_to r #p v; +} + +let to_array_ghost r = r + +unobservable +fn to_array u#a (#a: Type u#a) (r: ref a) #p (#v: erased a) + requires r |-> Frac p v + returns arr: array a + ensures rewrites_to arr (to_array_ghost r) + ensures arr |-> Frac p (seq![reveal v]) + ensures pure (length arr == 1) +{ + unfold pts_to r #p v; + pts_to_len r; + assert pure (Seq.equal seq![reveal v] (singleton (reveal v))); + r +} + +ghost +fn return_to_array u#a (#a: Type u#a) (r: ref a) #p (#v: Seq.seq a) + requires to_array_ghost r |-> Frac p v + requires pure (length (to_array_ghost r) == 1) + returns _: squash (Seq.length v == 1) + ensures r |-> Frac p (Seq.index v 0) +{ + pts_to_len r; + assert pure (singleton (Seq.Base.index v 0) `Seq.equal` v); + fold pts_to r #p (Seq.index v 0); +} + +let array_at_ghost arr i = gsub arr i (i+1) + +unobservable +fn array_at u#a (#a: Type u#a) (arr: array a) (i: SizeT.t) #p (#v: erased (Seq.seq a) { SizeT.v i < length arr /\ length arr == Seq.length v }) #mask + requires pts_to_mask arr #p v mask + requires pure (mask (SizeT.v i)) + returns r: ref a + ensures rewrites_to r (array_at_ghost arr (SizeT.v i)) + ensures r |-> Frac p (Seq.index v (SizeT.v i)) + ensures pts_to_mask arr #p v (fun k -> mask k /\ k <> SizeT.v i) +{ + let res = sub arr i (SizeT.v i + 1); + mask_ext res (singleton (Seq.index v (SizeT.v i))) (fun _ -> True); + from_mask res; + fold pts_to res #p (Seq.index v (SizeT.v i)); + mask_mext arr (fun k -> mask k /\ k <> SizeT.v i); + res +} + +ghost +fn return_array_at u#a (#a: Type u#a) (arr: array a) (i: nat) (#p: perm) (#v: a) (#v': Seq.seq a { i < length arr /\ length arr == Seq.length v' }) (#mask: nat->prop) + requires array_at_ghost arr i |-> Frac p v + requires pts_to_mask arr #p v' mask + requires pure (~(mask i)) + ensures pts_to_mask arr #p (Seq.upd v' i v) (fun k -> mask k \/ k == i) +{ + unfold pts_to (array_at_ghost arr i) #p v; + to_mask (array_at_ghost arr i); + gsub_elim arr i (i+1); + join_mask arr; + mask_ext arr (Seq.upd v' i v) (fun k -> mask k \/ k == i); +} + +fn replace u#a (#a:Type u#a) (r:ref a) (x:a) (#v:erased a) + requires r |-> v + returns res: a + ensures r |-> x + ensures rewrites_to res v +{ + let y = !r; + r := x; + y +} \ No newline at end of file diff --git a/lib/pulse/lib/Pulse.Lib.Reference.fsti b/lib/pulse/lib/Pulse.Lib.Reference.fsti index c04ef9006..35757d8be 100644 --- a/lib/pulse/lib/Pulse.Lib.Reference.fsti +++ b/lib/pulse/lib/Pulse.Lib.Reference.fsti @@ -16,172 +16,122 @@ module Pulse.Lib.Reference #lang-pulse - -open FStar.Tactics -open FStar.Ghost open Pulse.Main open Pulse.Lib.Core -open Pulse.Class.PtsTo open PulseCore.FractionalPermission -open Pulse.Lib.Array.Core - -inline_for_extraction -val ref ([@@@unused] a:Type u#0) : Type u#0 +open FStar.Ghost +open Pulse.Class.PtsTo +open Pulse.Lib.Array.Basic +open Pulse.Lib.SmallType +module T = FStar.Tactics +val ref ([@@@unused]a:Type) : Type0 -inline_for_extraction -val null (#a:Type u#0) : ref a +val null #a : ref a -inline_for_extraction val is_null #a (r : ref a) : b:bool{b <==> r == null #a} -val pts_to - (#a:Type) - ([@@@mkey] r:ref a) - (#[exact (`1.0R)] p:perm) - (n:a) - : slprop +val pts_to (#a:Type u#a) ([@@@mkey]r:ref a) (#[T.exact (`1.0R)] p:perm) (n:a) : slprop [@@pulse_unfold] -instance has_pts_to_ref (a:Type) : has_pts_to (ref a) a = { +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); } -val pts_to_timeless (#a:Type) ([@@@mkey] r:ref a) (p:perm) (x:a) - : Lemma (timeless (pts_to r #p x)) - [SMTPat (timeless (pts_to r #p x))] +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))] val is_full_ref #a (x: ref a) : prop -[@@deprecated "Reference.alloc is unsound; use Box.alloc instead"] -inline_for_extraction -fn alloc - (#a:Type) - (x:a) +[@@deprecated "Reference.alloc is unsound; only use for model implementations"] +fn alloc u#a (#a: Type u#a) {| small_type u#a |} (x:a) returns r : ref a ensures r |-> x ensures pure (is_full_ref r) - -inline_for_extraction -fn read - (#a:Type) - (r:ref a) - (#n:erased a) - (#p:perm) + +fn read u#a (#a: Type u#a) (r:ref a) (#n:erased a) (#p:perm) preserves r |-> Frac p n returns x : a - ensures rewrites_to x n + ensures rewrites_to x n (* alias for read *) inline_for_extraction -fn ( ! ) - (#a:Type) - (r:ref a) - (#n:erased a) - (#p:perm) +fn ( ! ) u#a (#a: Type u#a) (r:ref a) (#n:erased a) (#p:perm) preserves r |-> Frac p n returns x : a - ensures rewrites_to x n + ensures rewrites_to x n -(* := *) -inline_for_extraction -fn write - (#a:Type) - (r:ref a) - (x:a) - (#n:erased a) +fn write u#a (#a: Type u#a) (r:ref a) (x:a) (#n:erased a) requires r |-> n ensures r |-> x (* alias for write *) inline_for_extraction -fn op_Colon_Equals - (#a:Type) - (r:ref a) - (x:a) - (#n:erased a) +fn ( := ) u#a (#a: Type u#a) (r:ref a) (x:a) (#n:erased a) requires r |-> n ensures r |-> x - -[@@deprecated "Reference.free is unsound; use Box.free instead"] - -inline_for_extraction -fn free - (#a:Type) - (r:ref a) - (#n:erased a) - requires r |-> n +[@@deprecated "Reference.free is unsound; only use for model implementations"] +fn free u#a (#a: Type u#a) (r:ref a) (#n:erased a) + requires pts_to r n requires pure (is_full_ref r) ghost -fn share - (#a:Type) - (r:ref a) - (#v:erased a) - (#p:perm) +fn share u#a (#a: Type u#a) (r:ref a) (#v:erased a) (#p:perm) requires r |-> Frac p v - ensures (r |-> Frac (p /. 2.0R) v) ** (r |-> Frac (p /. 2.0R) v) + ensures (r |-> Frac (p /. 2.0R) v) ** + (r |-> Frac (p /. 2.0R) v) [@@allow_ambiguous] ghost -fn gather - (#a:Type) - (r:ref a) - (#x0 #x1:erased a) - (#p0 #p1:perm) +fn gather u#a (#a: Type u#a) (r:ref a) (#x0 #x1:erased a) (#p0 #p1:perm) requires (r |-> Frac p0 x0) ** (r |-> Frac p1 x1) ensures (r |-> Frac (p0 +. p1) x0) ** pure (x0 == x1) val with_local + (#a:Type u#a) {| small_type u#a |} + (init:a) + (#pre:slprop) + (#ret_t:Type u#b) + (#post:ret_t -> slprop) + (body:(r:ref a) -> stt ret_t (pre ** pts_to r init) + (fun v -> post v ** (exists* (x:a). pts_to r x))) + : stt ret_t pre (fun r -> post r) + +let with_local0 (#a:Type0) (init:a) (#pre:slprop) - (#ret_t:Type) + (#ret_t:Type u#b) (#post:ret_t -> slprop) (body:(r:ref a) -> stt ret_t (pre ** pts_to r init) - (fun v -> post v ** (exists* v. pts_to r v))) + (fun v -> post v ** (exists* (x:a). pts_to r x))) : stt ret_t pre (fun r -> post r) + = with_local init body [@@allow_ambiguous] ghost -fn pts_to_injective_eq - (#a:Type0) - (#p #q:perm) - (#v0 #v1:a) - (r:ref a) +fn pts_to_injective_eq u#a (#a: Type u#a) + (#p #q:_) + (#v0 #v1:a) + (r:ref a) preserves (r |-> Frac p v0) ** (r |-> Frac q v1) - ensures pure (v0 == v1) + ensures pure (v0 == v1) ghost -fn pts_to_perm_bound - (#a:Type0) - (#p:perm) - (r:ref a) - (#v:a) +fn pts_to_perm_bound u#a (#a: Type u#a) (#p:_) (r:ref a) (#v:a) preserves r |-> Frac p v ensures pure (p <=. 1.0R) ghost -fn pts_to_not_null (#a:_) (#p:_) (r:ref a) (#v:a) +fn pts_to_not_null u#a (#a: Type u#a) (#p:_) (r:ref a) (#v:a) preserves r |-> Frac p v ensures pure (not (is_null #a r)) -fn replace - (#a:Type0) - (r:ref a) - (x:a) - (#v:erased a) - requires r |-> v - returns res : a - ensures r |-> x - ensures rewrites_to res v - - val to_array_ghost #a (r: ref a) : GTot (array a) -inline_for_extraction unobservable -fn to_array #a (r: ref a) #p (#v: erased a) +fn to_array u#a (#a: Type u#a) (r: ref a) #p (#v: erased a) requires r |-> Frac p v returns arr: array a ensures rewrites_to arr (to_array_ghost r) @@ -189,17 +139,16 @@ fn to_array #a (r: ref a) #p (#v: erased a) ensures pure (length arr == 1) ghost -fn return_to_array #a (r: ref a) #p (#v: Seq.seq a) +fn return_to_array u#a (#a: Type u#a) (r: ref a) #p (#v: Seq.seq a) requires to_array_ghost r |-> Frac p v requires pure (length (to_array_ghost r) == 1) returns _: squash (Seq.length v == 1) ensures r |-> Frac p (Seq.index v 0) -val array_at_ghost #a (arr: array a) (i: nat { i < length arr }) : GTot (r:ref a { to_array_ghost r == gsub arr i (i+1) }) +val array_at_ghost (#a: Type u#a) (arr: array a) (i: nat { i < length arr }) : GTot (r:ref a { to_array_ghost r == gsub arr i (i+1) }) -inline_for_extraction unobservable -fn array_at #a (arr: array a) (i: SizeT.t) #p (#v: erased (Seq.seq a) { SizeT.v i < length arr /\ length arr == Seq.length v }) #mask +fn array_at u#a (#a: Type u#a) (arr: array a) (i: SizeT.t) #p (#v: erased (Seq.seq a) { SizeT.v i < length arr /\ length arr == Seq.length v }) #mask requires pts_to_mask arr #p v mask requires pure (mask (SizeT.v i)) returns r: ref a @@ -208,8 +157,14 @@ fn array_at #a (arr: array a) (i: SizeT.t) #p (#v: erased (Seq.seq a) { SizeT.v ensures pts_to_mask arr #p v (fun k -> mask k /\ k <> SizeT.v i) ghost -fn return_array_at #a (arr: array a) (i: nat) (#p: perm) (#v: a) (#v': Seq.seq a { i < length arr /\ length arr == Seq.length v' }) (#mask: nat->prop) +fn return_array_at u#a (#a: Type u#a) (arr: array a) (i: nat) (#p: perm) (#v: a) (#v': Seq.seq a { i < length arr /\ length arr == Seq.length v' }) (#mask: nat->prop) requires array_at_ghost arr i |-> Frac p v requires pts_to_mask arr #p v' mask requires pure (~(mask i)) - ensures pts_to_mask arr #p (Seq.upd v' i v) (fun k -> mask k \/ k == i) \ No newline at end of file + ensures pts_to_mask arr #p (Seq.upd v' i v) (fun k -> mask k \/ k == i) + +fn replace u#a (#a:Type u#a) (r:ref a) (x:a) (#v:erased a) + requires r |-> v + returns res: a + ensures r |-> x + ensures rewrites_to res v \ No newline at end of file diff --git a/lib/pulse/lib/Pulse.Lib.SmallType.fst b/lib/pulse/lib/Pulse.Lib.SmallType.fst index 2e66b7a51..1499417f9 100644 --- a/lib/pulse/lib/Pulse.Lib.SmallType.fst +++ b/lib/pulse/lib/Pulse.Lib.SmallType.fst @@ -18,14 +18,15 @@ module U = Pulse.Lib.Raise // Type class of types that can be stored in a reference [@@Tactics.Typeclasses.tcclass; erasable] -let small_type = U.raisable u#a u#2 +let small_type = U.raisable u#a u#3 inline_for_extraction noextract instance small_type_non_info : Pulse.Lib.NonInformative.non_informative (small_type u#a) = U.raisable_non_info instance small_type0 : small_type u#0 = U.raisable_inst -instance small_type1 : small_type u#1 = U.raisable_inst u#1 u#2 -instance small_type2 : small_type u#2 = U.raisable_inst u#2 u#2 +instance small_type1 : small_type u#1 = U.raisable_inst u#1 u#3 +instance small_type2 : small_type u#2 = U.raisable_inst u#2 u#3 +instance small_type3 : small_type u#3 = U.raisable_inst u#3 u#3 -instance of_small_type {| inst : small_type u#a |} : U.raisable u#a u#2 = inst +instance of_small_type {| inst : small_type u#a |} : U.raisable u#a u#3 = inst diff --git a/lib/pulse/lib/Pulse.Lib.Vec.fsti b/lib/pulse/lib/Pulse.Lib.Vec.fsti index 4a9d7558f..7c0684018 100644 --- a/lib/pulse/lib/Pulse.Lib.Vec.fsti +++ b/lib/pulse/lib/Pulse.Lib.Vec.fsti @@ -26,7 +26,7 @@ module Seq = FStar.Seq module T = FStar.Tactics.V2 module R = Pulse.Lib.Reference -module A = Pulse.Lib.Array.Core +module A = Pulse.Lib.Array.Basic val vec ([@@@strictly_positive] a:Type0) : Type u#0 diff --git a/lib/pulse/lib/ml/Pulse_Lib_Reference.ml b/lib/pulse/lib/ml/Pulse_Lib_Reference.ml index 296ef7399..9e9add3c8 100644 --- a/lib/pulse/lib/ml/Pulse_Lib_Reference.ml +++ b/lib/pulse/lib/ml/Pulse_Lib_Reference.ml @@ -2,7 +2,7 @@ let op_Bang (r:'a ref) () () = !r let read = op_Bang let op_Colon_Equals (r:'a ref) (v:'a) () = r := v let write = op_Colon_Equals -let alloc (v:'a) = ref v +let alloc () (v:'a) = ref v (* dummy null ref *) let __null : int ref = alloc 0 diff --git a/pulse2rust/dpe/src/generated/dpe.rs b/pulse2rust/dpe/src/generated/dpe.rs index 2c932ddac..95d130c35 100644 --- a/pulse2rust/dpe/src/generated/dpe.rs +++ b/pulse2rust/dpe/src/generated/dpe.rs @@ -86,10 +86,11 @@ pub fn maybe_mk_session_tbl( match sopt { None => { let tbl = super::pulse_lib_hashtable::alloc(super::dpe::sid_hash, 256); - super::dpe::st { + let s = super::dpe::st { st_ctr: 0, st_tbl: tbl, - } + }; + s } Some(mut s) => s, } @@ -458,6 +459,8 @@ pub fn certify_key( crt_len: u32, crt: &mut [u8], t: (), + pub_key_repr: (), + crt_repr: (), ) -> u32 { let s = super::dpe::replace_session(sid, (), super::dpe::session_state::InUse, ()); match s { @@ -511,6 +514,8 @@ pub fn sign( msg_len: usize, msg: &mut [u8], t: (), + signature_repr: (), + msg_repr: (), ) -> () { let s = super::dpe::replace_session(sid, (), super::dpe::session_state::InUse, ()); match s { diff --git a/pulse2rust/src/Pulse2Rust.Extract.fst b/pulse2rust/src/Pulse2Rust.Extract.fst index affd0e4d0..86d167ec3 100644 --- a/pulse2rust/src/Pulse2Rust.Extract.fst +++ b/pulse2rust/src/Pulse2Rust.Extract.fst @@ -172,14 +172,14 @@ let rec extract_mlty (g:env) (t:S.mlty) : typ = S.string_of_mlpath p = "Prims.dtuple2" -> mk_tuple_typ (List.map (extract_mlty g) l) | S.MLTY_Named ([arg], p) - when S.string_of_mlpath p = "Pulse.Lib.HigherReference.ref" -> + when S.string_of_mlpath p = "Pulse.Lib.Reference.ref" -> let is_mut = true in arg |> extract_mlty g |> mk_ref_typ is_mut | S.MLTY_Named ([arg], p) when S.string_of_mlpath p = "Pulse.Lib.Box.box" -> arg |> extract_mlty g |> mk_box_typ | S.MLTY_Named ([arg], p) - when S.string_of_mlpath p = "Pulse.Lib.HigherArray.Core.array" -> + when S.string_of_mlpath p = "Pulse.Lib.Array.Core.array" -> let is_mut = true in mk_slice is_mut arg | S.MLTY_Named ([arg], p) @@ -449,8 +449,8 @@ let rec lb_init_and_def (g:env) (lb:S.mllb) match lb.mllb_def.expr, lb.mllb_tysc with | S.MLE_App ({expr=S.MLE_TApp ({expr=S.MLE_Name pe}, _)}, [_; init]), Some ([], S.MLTY_Named ([ty], pt)) - when S.string_of_mlpath pe = "Pulse.Lib.HigherReference.alloc" && - S.string_of_mlpath pt = "Pulse.Lib.HigherReference.ref" -> + when S.string_of_mlpath pe = "Pulse.Lib.Reference.alloc" && + S.string_of_mlpath pt = "Pulse.Lib.Reference.ref" -> let is_mut = true in is_mut, extract_mlty g ty, @@ -458,8 +458,8 @@ let rec lb_init_and_def (g:env) (lb:S.mllb) | 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.HigherArray.Core.mask_alloc" && - S.string_of_mlpath pt = "Pulse.Lib.HigherArray.Core.array" -> + when S.string_of_mlpath pe = "Pulse.Lib.Array.Core.mask_alloc" && + S.string_of_mlpath pt = "Pulse.Lib.Array.Core.array" -> let init = extract_mlexpr g init in let len = extract_mlexpr g len in let is_mut = false in @@ -557,7 +557,7 @@ and extract_mlexpr (g:env) (e:S.mlexpr) : expr = mk_expr_field_unnamed e 2 | S.MLE_App ({expr=S.MLE_TApp ({expr=S.MLE_Name p}, [_])}, [e1; e2; _]) - when S.string_of_mlpath p = "Pulse.Lib.HigherReference.write" || + when S.string_of_mlpath p = "Pulse.Lib.Reference.write" || S.string_of_mlpath p = "Pulse.Lib.Box.op_Colon_Equals" || S.string_of_mlpath p = "Pulse.Lib.Mutex.op_Colon_Equals" -> let e1 = extract_mlexpr g e1 in @@ -569,7 +569,7 @@ and extract_mlexpr (g:env) (e:S.mlexpr) : expr = then mk_ref_assign e1 e2 else mk_assign e1 e2 | S.MLE_App ({expr=S.MLE_TApp ({expr=S.MLE_Name p}, [_])}, [e; _; _]) - when S.string_of_mlpath p = "Pulse.Lib.HigherReference.read" || + when S.string_of_mlpath p = "Pulse.Lib.Reference.read" || S.string_of_mlpath p = "Pulse.Lib.Box.op_Bang" || S.string_of_mlpath p = "Pulse.Lib.Mutex.op_Bang" -> let e = extract_mlexpr g e in @@ -604,7 +604,7 @@ and extract_mlexpr (g:env) (e:S.mlexpr) : expr = | S.MLE_App ({expr=S.MLE_TApp ({expr=S.MLE_Name p}, [_])}, e::i::_) - when S.string_of_mlpath p = "Pulse.Lib.HigherArray.Core.mask_read" || + when S.string_of_mlpath p = "Pulse.Lib.Array.Core.mask_read" || S.string_of_mlpath p = "Pulse.Lib.Slice.op_Array_Access" || S.string_of_mlpath p = "Pulse.Lib.Vec.op_Array_Access" || S.string_of_mlpath p = "Pulse.Lib.Vec.read_ref" -> @@ -612,7 +612,7 @@ and extract_mlexpr (g:env) (e:S.mlexpr) : expr = mk_expr_index (extract_mlexpr g e) (extract_mlexpr g i) | S.MLE_App ({expr=S.MLE_TApp ({expr=S.MLE_Name p}, [_])}, e1::e2::e3::_) - when S.string_of_mlpath p = "Pulse.Lib.HigherArray.Core.mask_write" || + when S.string_of_mlpath p = "Pulse.Lib.Array.Core.mask_write" || S.string_of_mlpath p = "Pulse.Lib.Slice.op_Array_Assignment" || S.string_of_mlpath p = "Pulse.Lib.Vec.op_Array_Assignment" || S.string_of_mlpath p = "Pulse.Lib.Vec.write_ref" -> @@ -676,7 +676,7 @@ and extract_mlexpr (g:env) (e:S.mlexpr) : expr = 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.HigherArray.Core.mask_alloc" -> + when S.string_of_mlpath p = "Pulse.Lib.Array.Core.mask_alloc" -> fail_nyi (Format.fmt1 "mlexpr %s" (S.mlexpr_to_string e)) @@ -710,7 +710,7 @@ and extract_mlexpr (g:env) (e:S.mlexpr) : expr = | S.MLE_App ({expr=S.MLE_TApp ({expr=S.MLE_Name p}, [_])}, [e1; e2; _]) - when S.string_of_mlpath p = "Pulse.Lib.HigherArray.Core.mask_free" -> + when S.string_of_mlpath p = "Pulse.Lib.Array.Core.mask_free" -> 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 934acbbfd..3a2908288 100644 --- a/share/pulse/examples/CustomSyntax.fst +++ b/share/pulse/examples/CustomSyntax.fst @@ -408,18 +408,18 @@ fn incr (x:nat) open Pulse.Lib.PCM.Fraction +module GR = Pulse.Lib.GhostPCMReference // // The example checks that ghost_pcm_ref is considered non-informative // - -fn test_ghost_ref_non_informative (#a:Type u#1) (y:a) +fn test_ghost_ref_non_informative u#a (#a:Type u#a) {|small_type u#a|} (y:a) requires emp ensures emp { full_values_compatible y; - let r = ghost_alloc #_ #(pcm_frac #a) (hide (Some (y, 1.0R))); - drop_ (ghost_pcm_pts_to r _); + let r = GR.alloc #_ #(pcm_frac #a) (hide (Some (y, 1.0R))); + drop_ (GR.pts_to r _); } diff --git a/share/pulse/examples/Example.StructPCM.fst b/share/pulse/examples/Example.StructPCM.fst index a64dae3af..b8135352c 100644 --- a/share/pulse/examples/Example.StructPCM.fst +++ b/share/pulse/examples/Example.StructPCM.fst @@ -18,8 +18,8 @@ module Example.StructPCM #lang-pulse open FStar.PCM -open Pulse.Lib.Core -open Pulse.Main +open Pulse +open Pulse.Lib.PCMReference module G = FStar.Ghost module PCM = FStar.PCM @@ -28,7 +28,7 @@ module PCM = FStar.PCM // This example sketches a PCM for updating fields of a pair in parallel // -type carrier (a:Type u#1) (b:Type u#1) : Type u#1 = +type carrier (a:Type0) (b:Type0) = | Unit | X : a -> carrier a b | Y : b -> carrier a b @@ -86,7 +86,7 @@ fn alloc #a #b (x:a) (y:b) returns r:ref a b ensures pcm_pts_to r (XY x y) { - Pulse.Lib.Core.alloc #_ #(spcm a b) (XY x y) + alloc #_ #(spcm a b) (XY x y) } @@ -98,7 +98,7 @@ fn share #a #b (r:ref a b) (#x:a) (#y:b) { rewrite pcm_pts_to r (XY x y) as pcm_pts_to r (X x `FStar.PCM.op (spcm a b)` Y y); - Pulse.Lib.Core.share r (G.hide (X x)) (G.hide (Y y)); + share r (G.hide (X x)) (G.hide (Y y)); } @@ -107,7 +107,7 @@ fn upd_x #a #b (r:ref a b) (x1 x2:a) requires pcm_pts_to r (X x1) ensures pcm_pts_to r (X x2) { - Pulse.Lib.Core.write r _ _ (pcm_upd_x x1 x2) + write r _ _ (pcm_upd_x x1 x2) } @@ -116,7 +116,7 @@ fn upd_y #a #b (r:ref a b) (y1 y2:b) requires pcm_pts_to r (Y y1) ensures pcm_pts_to r (Y y2) { - Pulse.Lib.Core.write r _ _ (pcm_upd_y y1 y2) + write r _ _ (pcm_upd_y y1 y2) } @@ -125,7 +125,7 @@ fn upd #a #b (r:ref a b) (x1 x2:a) (y1 y2:b) requires pcm_pts_to r (XY x1 y1) ensures pcm_pts_to r (XY x2 y2) { - Pulse.Lib.Core.write r _ _ (pcm_upd_xy x1 x2 y1 y2) + write r _ _ (pcm_upd_xy x1 x2 y1 y2) } @@ -135,7 +135,7 @@ fn gather #a #b (r:ref a b) (#x:a) (#y:b) pcm_pts_to r (Y y) ensures pcm_pts_to r (XY x y) { - Pulse.Lib.Core.gather r (G.hide (X x)) (G.hide (Y y)); + gather r (G.hide (X x)) (G.hide (Y y)); rewrite pcm_pts_to r (X x `FStar.PCM.op (spcm a b)` Y y) as pcm_pts_to r (XY x y) diff --git a/share/pulse/examples/GhostBag.fst b/share/pulse/examples/GhostBag.fst index c00ba0baf..5524403b3 100644 --- a/share/pulse/examples/GhostBag.fst +++ b/share/pulse/examples/GhostBag.fst @@ -19,7 +19,6 @@ module GhostBag // // This module implements the ghost bag data structure from -#lang-pulse // Expressive modular fine-grained concurrency specification, POPL 2011 (Sec. 6) // // @@ -49,7 +48,7 @@ type map (a:eqtype) = m:Map.t a (option perm) { forall (x:a). Map.contains m x } // so if x and y are in the set, F will map x and y to non-zero permissions // noeq -type gbag_pcm_carrier (a:eqtype) : Type u#1 = +type gbag_pcm_carrier (a:eqtype) = | P : map a -> gbag_pcm_carrier a | F : map a -> gbag_pcm_carrier a @@ -235,26 +234,28 @@ let fp_upd_rem #a v_new #pop-options -let gbag #a (r:ghost_pcm_ref (gbag_pcm a)) (s:Set.set a) : slprop = +module GR = Pulse.Lib.GhostPCMReference + +let gbag #a (r:GR.gref (gbag_pcm a)) (s:Set.set a) : slprop = exists* (m:map a). - ghost_pcm_pts_to r (F m) ** + GR.pts_to r (F m) ** (pure (forall (x:a). (~ (Set.mem x s)) ==> Map.sel m x == None)) ** (pure (forall (x:a). Set.mem x s ==> Map.sel m x == Some 0.5R)) -let gbagh #a (r:ghost_pcm_ref (gbag_pcm a)) (x:a) : slprop = - ghost_pcm_pts_to r (P (Map.upd (Map.const None) x (Some 0.5R))) +let gbagh #a (r:GR.gref (gbag_pcm a)) (x:a) : slprop = + GR.pts_to r (P (Map.upd (Map.const None) x (Some 0.5R))) ghost fn gbag_create (a:eqtype) requires emp - returns r:ghost_pcm_ref (gbag_pcm a) + returns r:GR.gref (gbag_pcm a) ensures gbag r Set.empty { - let r = ghost_alloc #_ #(gbag_pcm a) (F (Map.const None)); - with _m. rewrite (ghost_pcm_pts_to r (Ghost.reveal (Ghost.hide _m))) as - (ghost_pcm_pts_to r _m); + let r = GR.alloc #_ #(gbag_pcm a) (F (Map.const None)); + with _m. rewrite (GR.pts_to r (Ghost.reveal (Ghost.hide _m))) as + (GR.pts_to r _m); fold (gbag r Set.empty); r } @@ -262,48 +263,48 @@ fn gbag_create (a:eqtype) ghost -fn gbag_add #a (r:ghost_pcm_ref (gbag_pcm a)) (s:Set.set a) (x:a) +fn gbag_add #a (r:GR.gref (gbag_pcm a)) (s:Set.set a) (x:a) requires gbag r s ** pure (~ (Set.mem x s)) ensures gbag r (Set.add x s) ** gbagh r x { unfold gbag; - with mf. assert (ghost_pcm_pts_to r (F mf)); - ghost_write r (F mf) (F (Map.upd mf x (Some 1.0R))) (fp_upd_add mf x); + with mf. assert (GR.pts_to r (F mf)); + GR.write r (F mf) (F (Map.upd mf x (Some 1.0R))) (fp_upd_add mf x); assert (pure (Map.equal (Map.upd mf x (Some 1.0R)) (op_maps (Map.upd mf x (Some 0.5R)) (Map.upd (Map.const None) x (Some 0.5R))))); - rewrite (ghost_pcm_pts_to r (F (Map.upd mf x (Some 1.0R)))) as - (ghost_pcm_pts_to r (op (gbag_pcm a) + rewrite (GR.pts_to r (F (Map.upd mf x (Some 1.0R)))) as + (GR.pts_to r (op (gbag_pcm a) (F (Map.upd mf x (Some 0.5R))) (P (Map.upd (Map.const None) x (Some 0.5R))))); - ghost_share r (F (Map.upd mf x (Some 0.5R))) + GR.share r (F (Map.upd mf x (Some 0.5R))) (P (Map.upd (Map.const None) x (Some 0.5R))); fold (gbag r (Set.add x s)); - with _v. rewrite (ghost_pcm_pts_to r (Ghost.reveal (Ghost.hide _v))) as + with _v. rewrite (GR.pts_to r (Ghost.reveal (Ghost.hide _v))) as (gbagh r x) } ghost -fn gbag_remove #a (r:ghost_pcm_ref (gbag_pcm a)) (s:Set.set a) (x:a) +fn gbag_remove #a (r:GR.gref (gbag_pcm a)) (s:Set.set a) (x:a) requires gbag r s ** gbagh r x ensures gbag r (Set.remove x s) ** pure (x `Set.mem` s) { unfold gbag; - with mf. assert (ghost_pcm_pts_to r (F mf)); + with mf. assert (GR.pts_to r (F mf)); unfold gbagh; let mp = Map.upd (Map.const #_ #(option perm) None) x (Some 0.5R); - with _m. rewrite (ghost_pcm_pts_to r (P _m)) as - (ghost_pcm_pts_to r (P mp)); - ghost_gather r (F mf) (P mp); + with _m. rewrite (GR.pts_to r (P _m)) as + (GR.pts_to r (P mp)); + GR.gather r (F mf) (P mp); assert (pure (x `Set.mem` s)); let mop = op_maps mf mp; - ghost_write r (F mop) (F (Map.upd mop x None)) (fp_upd_rem mop x); + GR.write r (F mop) (F (Map.upd mop x None)) (fp_upd_rem mop x); fold (gbag r (Set.remove x s)) } diff --git a/share/pulse/examples/PulseExample.BinarySearch.fst b/share/pulse/examples/PulseExample.BinarySearch.fst index 12660e172..bb8fa4928 100644 --- a/share/pulse/examples/PulseExample.BinarySearch.fst +++ b/share/pulse/examples/PulseExample.BinarySearch.fst @@ -7,8 +7,8 @@ module Seq = FStar.Seq open Pulse.Lib.TotalOrder open Pulse.Lib.BoundedIntegers -fn binary_search - (#t:Type) +fn binary_search u#a + (#t:Type u#a) {| total_order t |} (a:A.array t) (key:t) diff --git a/share/pulse/examples/PulseLambdas.fst b/share/pulse/examples/PulseLambdas.fst index e2eabb76c..3ae4057ed 100644 --- a/share/pulse/examples/PulseLambdas.fst +++ b/share/pulse/examples/PulseLambdas.fst @@ -84,7 +84,7 @@ fn test_inner_lambda (#a:Type0) requires pts_to x 'vx ** pts_to y 'vy ensures pts_to x 'vy ** pts_to y 'vy { - fn write_helper (#a:Type) (x:ref a) (n:a) (#vx:erased a) + fn write_helper (#a:Type0) (x:ref a) (n:a) (#vx:erased a) requires pts_to x vx ensures pts_to x n { diff --git a/share/pulse/examples/by-example/ParallelIncrement.fst b/share/pulse/examples/by-example/ParallelIncrement.fst index ea7f55d12..8e12bd296 100644 --- a/share/pulse/examples/by-example/ParallelIncrement.fst +++ b/share/pulse/examples/by-example/ParallelIncrement.fst @@ -179,7 +179,7 @@ val atomic_increment (r:ref int) (#i:erased int) let test (l:iname) = assert (not (mem_inv emp_inames l)) -let pts_to_refine #a (x:ref a) (p:a -> slprop) = exists* v. pts_to x v ** p v +let pts_to_refine (#a: Type0) (x:ref a) (p:a -> slprop) = exists* v. pts_to x v ** p v fn atomic_increment_f2 (x: ref int) diff --git a/share/pulse/examples/by-example/PulseTutorial.Array.fst b/share/pulse/examples/by-example/PulseTutorial.Array.fst index 9a2ae7468..41ca7df57 100644 --- a/share/pulse/examples/by-example/PulseTutorial.Array.fst +++ b/share/pulse/examples/by-example/PulseTutorial.Array.fst @@ -24,7 +24,7 @@ module SZ = FStar.SizeT //readi$ fn read_i - (#[@@@ Rust_generics_bounds ["Copy"]] t:Type) + (#[@@@ Rust_generics_bounds ["Copy"]] t:Type0) (arr:array t) (#p:perm) (#s:erased (Seq.seq t)) @@ -38,7 +38,7 @@ fn read_i //end readi$ //writei$ -fn write_i (#t:Type) (arr:array t) (#s:erased (Seq.seq t)) (x:t) (i:SZ.t { SZ.v i < Seq.length s }) +fn write_i (#t:Type0) (arr:array t) (#s:erased (Seq.seq t)) (x:t) (i:SZ.t { SZ.v i < Seq.length s }) requires pts_to arr s ensures pts_to arr (Seq.upd s (SZ.v i) x) { diff --git a/share/pulse/examples/by-example/PulseTutorial.AtomicsAndInvariants.fst b/share/pulse/examples/by-example/PulseTutorial.AtomicsAndInvariants.fst index d84afe6f5..102a3ab6d 100644 --- a/share/pulse/examples/by-example/PulseTutorial.AtomicsAndInvariants.fst +++ b/share/pulse/examples/by-example/PulseTutorial.AtomicsAndInvariants.fst @@ -95,7 +95,7 @@ opens [i] ghost -fn pts_to_dup_impossible #a (x:ref a) +fn pts_to_dup_impossible u#a (#a: Type u#a) (x:ref a) requires pts_to x 'v ** pts_to x 'u ensures pts_to x 'v ** pts_to x 'u ** pure False { diff --git a/share/pulse/examples/by-example/PulseTutorial.Conditionals.fst b/share/pulse/examples/by-example/PulseTutorial.Conditionals.fst index 66e381035..eb37c0635 100644 --- a/share/pulse/examples/by-example/PulseTutorial.Conditionals.fst +++ b/share/pulse/examples/by-example/PulseTutorial.Conditionals.fst @@ -93,7 +93,7 @@ ensures pts_to x #p 'vx ** pts_to y #q 'vy //nullable_ref$ -let nullable_ref a = option (ref a) +let nullable_ref (a: Type0) = option (ref a) let pts_to_or_null #a (x:nullable_ref a) diff --git a/share/pulse/examples/by-example/PulseTutorial.Existentials.fst b/share/pulse/examples/by-example/PulseTutorial.Existentials.fst index 8d45cc7c4..7acec7ce6 100644 --- a/share/pulse/examples/by-example/PulseTutorial.Existentials.fst +++ b/share/pulse/examples/by-example/PulseTutorial.Existentials.fst @@ -20,7 +20,7 @@ open Pulse.Lib.Pervasives open FStar.Mul //assign$ -fn assign #a (x:ref a) (v:a) +fn assign (#a: Type0) (x:ref a) (v:a) requires exists* w. pts_to x w ensures diff --git a/share/pulse/examples/by-example/PulseTutorial.Ghost.fst b/share/pulse/examples/by-example/PulseTutorial.Ghost.fst index 0b0bf1659..0d29c0458 100644 --- a/share/pulse/examples/by-example/PulseTutorial.Ghost.fst +++ b/share/pulse/examples/by-example/PulseTutorial.Ghost.fst @@ -184,7 +184,7 @@ decreases l module GR = Pulse.Lib.GhostReference //new_ghost_ref$ ghost -fn new_ghost_ref #a (x:a) +fn new_ghost_ref (#a: Type0) (x:a) requires emp returns r:GR.ref a ensures GR.pts_to r x @@ -219,11 +219,11 @@ ensures exists* v1. correlated x y v1 //end use_temp_sig$ //use_temp_body$ { - unfold correlated; + unfold correlated u#0; let v = !x; x := 17; //temporarily mutate x, give to to another function to use with full perm x := v; //but, we're forced to set it back to its original value - fold correlated; + fold correlated u#0; } //end use_temp_body$ @@ -237,9 +237,9 @@ ensures emp let mut x = 17; let g = GR.alloc 17; GR.share g; - fold correlated; // GR.pts_to g #0.5R 17 ** correlated x g 17 + fold correlated u#0; // GR.pts_to g #0.5R 17 ** correlated x g 17 use_temp x g; // GR.pts_to g #0.5R 17 ** correlated x g ?v1 - unfold correlated; // GR.pts_to g #0.5R 17 ** GR.pts_to g #0.5R ?v1 ** pts_to x ?v1 + unfold correlated u#0; // GR.pts_to g #0.5R 17 ** GR.pts_to g #0.5R ?v1 ** pts_to x ?v1 GR.gather g; //this is the crucial step // GT.pts_to g 17 ** pure (?v1 == 17) ** pts_to x ?v1 assert (pts_to x 17); diff --git a/share/pulse/examples/by-example/PulseTutorial.ImplicationAndForall.fst b/share/pulse/examples/by-example/PulseTutorial.ImplicationAndForall.fst index 35206502d..e8dc91cc1 100644 --- a/share/pulse/examples/by-example/PulseTutorial.ImplicationAndForall.fst +++ b/share/pulse/examples/by-example/PulseTutorial.ImplicationAndForall.fst @@ -24,7 +24,7 @@ module GR = Pulse.Lib.GhostReference open GR //regain_half$ -let regain_half #a (x:GR.ref a) (v:a) = +let regain_half (#a: Type0) (x:GR.ref a) (v:a) = pts_to x #0.5R v @==> pts_to x v //end regain_half$ @@ -57,7 +57,7 @@ ensures pts_to x 'v //regain_half_q$ -let regain_half_q #a (x:GR.ref a) = +let regain_half_q (#a: Type0) (x:GR.ref a) = forall* u. pts_to x #0.5R u @==> pts_to x u //end regain_half_q$ diff --git a/share/pulse/examples/by-example/PulseTutorial.MonotonicRef.fst b/share/pulse/examples/by-example/PulseTutorial.MonotonicRef.fst index a649b3ce5..4d05c614f 100644 --- a/share/pulse/examples/by-example/PulseTutorial.MonotonicRef.fst +++ b/share/pulse/examples/by-example/PulseTutorial.MonotonicRef.fst @@ -26,7 +26,7 @@ let full (#t:Type) (#p:preorder t) (v:t) : FP.pcm_carrier p = (Some 1.0R, [v]) ghost -fn alloc (#t:Type0) (#p:preorder t) (v:t) +fn alloc u#a (#t:Type u#a) {| small_type u#a |} (#p:preorder t) (v:t) requires emp returns r:mref p ensures pts_to r #1.0R v @@ -37,11 +37,11 @@ ensures pts_to r #1.0R v } ghost -fn take_snapshot (#t:Type) (#p:preorder t) (r:mref p) (#f:perm) (v:t) +fn take_snapshot u#a (#t:Type u#a) (#p:preorder t) (r:mref p) (#f:perm) (v:t) requires pts_to r #f v ensures pts_to r #f v ** snapshot r v { - unfold pts_to; + unfold pts_to u#a; with h. assert (GR.pts_to r (Some f, h)); rewrite (GR.pts_to r (Some f, h)) as (GR.pts_to r ((Some f, h) `(FP.fp_pcm p).p.op` (None, h))); @@ -51,13 +51,13 @@ ensures pts_to r #f v ** snapshot r v } ghost -fn recall_snapshot (#t:Type) (#p:preorder t) (r:mref p) (#f:perm) (#v #u:t) +fn recall_snapshot u#a (#t:Type u#a) (#p:preorder t) (r:mref p) (#f:perm) (#v #u:t) requires pts_to r #f v ** snapshot r u ensures pts_to r #f v ** snapshot r u ** pure (as_prop (p u v)) { - unfold pts_to; + unfold pts_to u#a; with h. assert (GR.pts_to r (Some f, h)); - unfold snapshot; + unfold snapshot u#a; with h'. assert (GR.pts_to r (None, h')); GR.gather r (Some f, h) (None, h'); GR.share r (Some f, h) (None, h'); @@ -66,11 +66,11 @@ ensures pts_to r #f v ** snapshot r u ** pure (as_prop (p u v)) } ghost -fn dup_snapshot (#t:Type) (#p:preorder t) (r:mref p) (#u:t) +fn dup_snapshot u#a (#t:Type u#a) (#p:preorder t) (r:mref p) (#u:t) requires snapshot r u ensures snapshot r u ** snapshot r u { - unfold snapshot; + unfold snapshot u#a; with h. assert (GR.pts_to r (None, h)); GR.share r (None, h) (None, h); fold (snapshot r u); @@ -78,12 +78,12 @@ ensures snapshot r u ** snapshot r u } ghost -fn update (#t:Type) (#p:preorder t) (r:mref p) (#u:t) (v:t) +fn update u#a (#t:Type u#a) (#p:preorder t) (r:mref p) (#u:t) (v:t) requires pts_to r #1.0R u ** pure (as_prop (p u v)) ensures pts_to r #1.0R v { - unfold pts_to; + unfold pts_to u#a; with f h. assert (GR.pts_to r (f, h)); GR.write r _ _ (FP.mk_frame_preserving_upd p h v); - fold pts_to; + fold pts_to u#a; } \ No newline at end of file diff --git a/share/pulse/examples/by-example/PulseTutorial.ParallelIncrement.fst b/share/pulse/examples/by-example/PulseTutorial.ParallelIncrement.fst index 388d48beb..8aa09915c 100644 --- a/share/pulse/examples/by-example/PulseTutorial.ParallelIncrement.fst +++ b/share/pulse/examples/by-example/PulseTutorial.ParallelIncrement.fst @@ -451,25 +451,22 @@ ensures pts_to x ('i + 2) open FStar.PCM -module U = Pulse.Lib.Raise module G = FStar.Ghost module Prod = Pulse.Lib.PCM.Product module Frac = Pulse.Lib.PCM.Fraction -type int1 : Type u#1 = U.raise_t int - -type ghost_st : Type u#1 = Frac.fractional int1 & Frac.fractional int1 +type ghost_st : Type0 = Frac.fractional int & Frac.fractional int let pcm : pcm ghost_st = Prod.pcm_prod Frac.pcm_frac Frac.pcm_frac -let with_p (n:int1) (p:perm) : Frac.fractional int1 = Some (n, p) -let full (n:int1) : Frac.fractional int1 = Some (n, 1.0R) -let half (n:int1) : Frac.fractional int1 = Some (n, 0.5R) +let with_p (n:int) (p:perm) : Frac.fractional int = Some (n, p) +let full (n:int) : Frac.fractional int = Some (n, 1.0R) +let half (n:int) : Frac.fractional int = Some (n, 0.5R) let fp_upd_t1 - (t1_old:G.erased int1) - (t1_new:int1) - (t2:int1) + (t1_old:G.erased int) + (t1_new:int) + (t2:int) (p2:perm) : frame_preserving_upd pcm (full t1_old, with_p t2 p2) (full t1_new, with_p t2 p2) = @@ -485,10 +482,10 @@ let fp_upd_t1 (Frac.mk_frame_preserving_upd t1_old t1_new) let fp_upd_t2 - (t1:int1) + (t1:int) (p1:perm) - (t2_old:G.erased int1) - (t2_new:int1) + (t2_old:G.erased int) + (t2_new:int) : frame_preserving_upd pcm (with_p t1 p1, full t2_old) (with_p t1 p1, full t2_new) = @@ -502,62 +499,63 @@ let fp_upd_t2 _ (Frac.mk_frame_preserving_upd t2_old t2_new) +module GPR = Pulse.Lib.GhostPCMReference ghost -fn share (r:ghost_pcm_ref pcm) (#n1 #n2:int1) - requires ghost_pcm_pts_to r (full n1, full n2) - ensures ghost_pcm_pts_to r (half n1, None) ** - ghost_pcm_pts_to r (None, half n2) ** - ghost_pcm_pts_to r (half n1, half n2) +fn share (r:GPR.gref pcm) (#n1 #n2:int) + requires GPR.pts_to r (full n1, full n2) + ensures GPR.pts_to r (half n1, None) ** + GPR.pts_to r (None, half n2) ** + GPR.pts_to r (half n1, half n2) { - rewrite (ghost_pcm_pts_to r (full n1, full n2)) as - (ghost_pcm_pts_to r ((half n1, None) `op pcm` (half n1, full n2))); - ghost_share r (half n1, None) (half n1, full n2); - rewrite (ghost_pcm_pts_to r (half n1, full n2)) as - (ghost_pcm_pts_to r ((None, half n2) `op pcm` (half n1, half n2))); - ghost_share r (None, half n2) (half n1, half n2) + rewrite (GPR.pts_to r (full n1, full n2)) as + (GPR.pts_to r ((half n1, None) `op pcm` (half n1, full n2))); + GPR.share r (half n1, None) (half n1, full n2); + rewrite (GPR.pts_to r (half n1, full n2)) as + (GPR.pts_to r ((None, half n2) `op pcm` (half n1, half n2))); + GPR.share r (None, half n2) (half n1, half n2) } ghost -fn gather (r:ghost_pcm_ref pcm) (#n1 #n2:int1) (#v1 #v2:int1) - requires ghost_pcm_pts_to r (half n1, None) ** - ghost_pcm_pts_to r (None, half n2) ** - ghost_pcm_pts_to r (half v1, half v2) +fn gather (r:GPR.gref pcm) (#n1 #n2:int) (#v1 #v2:int) + requires GPR.pts_to r (half n1, None) ** + GPR.pts_to r (None, half n2) ** + GPR.pts_to r (half v1, half v2) returns _:squash (v1 == n1 /\ v2 == n2) - ensures ghost_pcm_pts_to r (full n1, full n2) + ensures GPR.pts_to r (full n1, full n2) { - ghost_gather r (None, half n2) (half v1, half v2); - rewrite (ghost_pcm_pts_to r ((None, half n2) `op pcm` (half v1, half v2))) as - (ghost_pcm_pts_to r (half v1, full n2)); - ghost_gather r (half n1, None) (half v1, full n2); - rewrite (ghost_pcm_pts_to r ((half n1, None) `op pcm` (half v1, full n2))) as - (ghost_pcm_pts_to r (full n1, full n2)) + GPR.gather r (None, half n2) (half v1, half v2); + rewrite (GPR.pts_to r ((None, half n2) `op pcm` (half v1, half v2))) as + (GPR.pts_to r (half v1, full n2)); + GPR.gather r (half n1, None) (half v1, full n2); + rewrite (GPR.pts_to r ((half n1, None) `op pcm` (half v1, full n2))) as + (GPR.pts_to r (full n1, full n2)) } -let lock_inv_ghost (ghost_r:ghost_pcm_ref pcm) (n:int) : timeless_slprop = - exists* n1 n2. ghost_pcm_pts_to ghost_r (half n1, half n2) ** - pure (n == U.downgrade_val n1 + U.downgrade_val n2) +let lock_inv_ghost (ghost_r:GPR.gref pcm) (n:int) : timeless_slprop = + exists* n1 n2. GPR.pts_to ghost_r (half n1, half n2) ** + pure (n == n1 + n2) -let lock_inv_pcm (r:ref int) (ghost_r:ghost_pcm_ref pcm) : timeless_slprop = +let lock_inv_pcm (r:ref int) (ghost_r:GPR.gref pcm) : timeless_slprop = exists* n. pts_to r n ** lock_inv_ghost ghost_r n -let t1_perm (ghost_r:ghost_pcm_ref pcm) (n:int1) (t1:bool) = +let t1_perm (ghost_r:GPR.gref pcm) (n:int) (t1:bool) = if t1 - then ghost_pcm_pts_to ghost_r (half n, None) - else ghost_pcm_pts_to ghost_r (None, half n) + then GPR.pts_to ghost_r (half n, None) + else GPR.pts_to ghost_r (None, half n) -let add_one (n:int1) : int1 = U.raise_val (U.downgrade_val n + 1) +let add_one (n:int) : int = n + 1 // // Lock, increment the reference, and // update the ghost state's first component if t1 = true, else the second // -fn incr_pcm_t (r:ref int) (ghost_r:ghost_pcm_ref pcm) (l:L.lock) (t1:bool) (#n:int1) +fn incr_pcm_t (r:ref int) (ghost_r:GPR.gref pcm) (l:L.lock) (t1:bool) (#n:int) requires L.lock_alive l #0.5R (lock_inv_pcm r ghost_r) ** t1_perm ghost_r n t1 ensures L.lock_alive l #0.5R (lock_inv_pcm r ghost_r) ** @@ -570,36 +568,36 @@ fn incr_pcm_t (r:ref int) (ghost_r:ghost_pcm_ref pcm) (l:L.lock) (t1:bool) (#n:i r := v + 1; if t1 { rewrite (t1_perm ghost_r n t1) as - (ghost_pcm_pts_to ghost_r (half n, None)); - with n1 n2. assert (ghost_pcm_pts_to ghost_r (half n1, half n2)); - ghost_gather ghost_r (half n, None) (half n1, half n2); - rewrite (ghost_pcm_pts_to ghost_r ((half n, None) `op pcm` (half n1, half n2))) as - (ghost_pcm_pts_to ghost_r (full n1, half n2)); - ghost_write ghost_r + (GPR.pts_to ghost_r (half n, None)); + with n1 n2. assert (GPR.pts_to ghost_r (half n1, half n2)); + GPR.gather ghost_r (half n, None) (half n1, half n2); + rewrite (GPR.pts_to ghost_r ((half n, None) `op pcm` (half n1, half n2))) as + (GPR.pts_to ghost_r (full n1, half n2)); + GPR.write ghost_r (full n1, half n2) (full (add_one n1), half n2) (fp_upd_t1 n1 (add_one n1) n2 0.5R); - rewrite (ghost_pcm_pts_to ghost_r (full (add_one n1), half n2)) as - (ghost_pcm_pts_to ghost_r ((half (add_one n1), half n2) `op pcm` (half (add_one n1), None))); - ghost_share ghost_r (half (add_one n1), half n2) (half (add_one n1), None); + rewrite (GPR.pts_to ghost_r (full (add_one n1), half n2)) as + (GPR.pts_to ghost_r ((half (add_one n1), half n2) `op pcm` (half (add_one n1), None))); + GPR.share ghost_r (half (add_one n1), half n2) (half (add_one n1), None); fold lock_inv_ghost; fold lock_inv_pcm; L.release l; fold (t1_perm ghost_r (add_one n) true); } else { rewrite (t1_perm ghost_r n t1) as - (ghost_pcm_pts_to ghost_r (None, half n)); - with n1 n2. assert (ghost_pcm_pts_to ghost_r (half n1, half n2)); - ghost_gather ghost_r (None, half n) (half n1, half n2); - rewrite (ghost_pcm_pts_to ghost_r ((None, half n2) `op pcm` (half n1, half n2))) as - (ghost_pcm_pts_to ghost_r (half n1, full n2)); - ghost_write ghost_r + (GPR.pts_to ghost_r (None, half n)); + with n1 n2. assert (GPR.pts_to ghost_r (half n1, half n2)); + GPR.gather ghost_r (None, half n) (half n1, half n2); + rewrite (GPR.pts_to ghost_r ((None, half n2) `op pcm` (half n1, half n2))) as + (GPR.pts_to ghost_r (half n1, full n2)); + GPR.write ghost_r (half n1, full n2) (half n1, full (add_one n2)) (fp_upd_t2 n1 0.5R n2 (add_one n2)); - rewrite (ghost_pcm_pts_to ghost_r (half n1, full (add_one n2))) as - (ghost_pcm_pts_to ghost_r ((half n1, half (add_one n2)) `op pcm` (None, half (add_one n2)))); - ghost_share ghost_r (half n1, half (add_one n2)) (None, half (add_one n2)); + rewrite (GPR.pts_to ghost_r (half n1, full (add_one n2))) as + (GPR.pts_to ghost_r ((half n1, half (add_one n2)) `op pcm` (None, half (add_one n2)))); + GPR.share ghost_r (half n1, half (add_one n2)) (None, half (add_one n2)); fold lock_inv_ghost; fold lock_inv_pcm; L.release l; @@ -608,24 +606,21 @@ fn incr_pcm_t (r:ref int) (ghost_r:ghost_pcm_ref pcm) (l:L.lock) (t1:bool) (#n:i } -let zero1 : int1 = U.raise_val 0 - - fn incr_pcm (r:ref int) (#n:erased int) requires pts_to r 0 ensures pts_to r 2 { - let ghost_r = ghost_alloc #_ #pcm (G.hide (full zero1, full zero1)); - with _v. rewrite (ghost_pcm_pts_to ghost_r (G.reveal (G.hide _v))) as - (ghost_pcm_pts_to ghost_r _v); + let ghost_r = GPR.alloc #_ #pcm (G.hide (full 0, full 0)); + with _v. rewrite (GPR.pts_to ghost_r (G.reveal (G.hide _v))) as + (GPR.pts_to ghost_r _v); share ghost_r; fold lock_inv_ghost; fold lock_inv_pcm; - rewrite (ghost_pcm_pts_to ghost_r (half zero1, None)) as - (t1_perm ghost_r zero1 true); - rewrite (ghost_pcm_pts_to ghost_r (None, half zero1)) as - (t1_perm ghost_r zero1 false); + rewrite (GPR.pts_to ghost_r (half 0, None)) as + (t1_perm ghost_r 0 true); + rewrite (GPR.pts_to ghost_r (None, half 0)) as + (t1_perm ghost_r 0 false); let l = L.new_lock (lock_inv_pcm r ghost_r); @@ -633,13 +628,13 @@ fn incr_pcm (r:ref int) (#n:erased int) parallel requires L.lock_alive l #0.5R (lock_inv_pcm r ghost_r) ** - t1_perm ghost_r zero1 true and + t1_perm ghost_r 0 true and L.lock_alive l #0.5R (lock_inv_pcm r ghost_r) ** - t1_perm ghost_r zero1 false + 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 zero1) true and + 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 zero1) false + t1_perm ghost_r (add_one 0) false { incr_pcm_t r ghost_r l true } { incr_pcm_t r ghost_r l false }; @@ -647,11 +642,11 @@ fn incr_pcm (r:ref int) (#n:erased int) L.acquire l; unfold lock_inv_pcm; unfold lock_inv_ghost; - unfold (t1_perm ghost_r (add_one zero1) true); - unfold (t1_perm ghost_r (add_one zero1) false); + unfold (t1_perm ghost_r (add_one 0) true); + unfold (t1_perm ghost_r (add_one 0) false); gather ghost_r; L.free l; - drop_ (ghost_pcm_pts_to ghost_r _) + drop_ (GPR.pts_to ghost_r _) } @@ -688,50 +683,50 @@ fn incr_pcm_abstract (r:ref int) requires pts_to r 0 ensures pts_to r 2 { - let ghost_r = ghost_alloc #_ #pcm (G.hide (full zero1, full zero1)); + let ghost_r = GPR.alloc #_ #pcm (G.hide (full 0, full 0)); ghost fn t1 (v:int) - requires ghost_pcm_pts_to ghost_r (half zero1, None) ** lock_inv_ghost ghost_r v - ensures ghost_pcm_pts_to ghost_r (half (add_one zero1), None) ** lock_inv_ghost ghost_r (v + 1) + requires GPR.pts_to ghost_r (half 0, None) ** lock_inv_ghost ghost_r v + ensures GPR.pts_to ghost_r (half (add_one 0), None) ** lock_inv_ghost ghost_r (v + 1) { unfold lock_inv_ghost; - with n1 n2. assert (ghost_pcm_pts_to ghost_r (half n1, half n2)); - ghost_gather ghost_r (half zero1, None) (half n1, half n2); - rewrite (ghost_pcm_pts_to ghost_r ((half zero1, None) `op pcm` (half n1, half n2))) as - (ghost_pcm_pts_to ghost_r (full n1, half n2)); - ghost_write ghost_r + with n1 n2. assert (GPR.pts_to ghost_r (half n1, half n2)); + GPR.gather ghost_r (half 0, None) (half n1, half n2); + rewrite (GPR.pts_to ghost_r ((half 0, None) `op pcm` (half n1, half n2))) as + (GPR.pts_to ghost_r (full n1, half n2)); + GPR.write ghost_r (full n1, half n2) (full (add_one n1), half n2) (fp_upd_t1 n1 (add_one n1) n2 0.5R); - rewrite (ghost_pcm_pts_to ghost_r (full (add_one n1), half n2)) as - (ghost_pcm_pts_to ghost_r ((half (add_one n1), half n2) `op pcm` (half (add_one n1), None))); - ghost_share ghost_r (half (add_one n1), half n2) (half (add_one n1), None); + rewrite (GPR.pts_to ghost_r (full (add_one n1), half n2)) as + (GPR.pts_to ghost_r ((half (add_one n1), half n2) `op pcm` (half (add_one n1), None))); + GPR.share ghost_r (half (add_one n1), half n2) (half (add_one n1), None); fold ((lock_inv_ghost ghost_r) (v + 1)) }; ghost fn t2 (v:int) - requires ghost_pcm_pts_to ghost_r (None, half zero1) ** lock_inv_ghost ghost_r v - ensures ghost_pcm_pts_to ghost_r (None, half (add_one zero1)) ** lock_inv_ghost ghost_r (v +1) + requires GPR.pts_to ghost_r (None, half 0) ** lock_inv_ghost ghost_r v + ensures GPR.pts_to ghost_r (None, half (add_one 0)) ** lock_inv_ghost ghost_r (v +1) { unfold lock_inv_ghost; - with n1 n2. assert (ghost_pcm_pts_to ghost_r (half n1, half n2)); - ghost_gather ghost_r (None, half zero1) (half n1, half n2); - rewrite (ghost_pcm_pts_to ghost_r ((None, half n2) `op pcm` (half n1, half n2))) as - (ghost_pcm_pts_to ghost_r (half n1, full n2)); - ghost_write ghost_r + with n1 n2. assert (GPR.pts_to ghost_r (half n1, half n2)); + GPR.gather ghost_r (None, half 0) (half n1, half n2); + rewrite (GPR.pts_to ghost_r ((None, half n2) `op pcm` (half n1, half n2))) as + (GPR.pts_to ghost_r (half n1, full n2)); + GPR.write ghost_r (half n1, full n2) (half n1, full (add_one n2)) (fp_upd_t2 n1 0.5R n2 (add_one n2)); - rewrite (ghost_pcm_pts_to ghost_r (half n1, full (add_one n2))) as - (ghost_pcm_pts_to ghost_r ((half n1, half (add_one n2)) `op pcm` (None, half (add_one n2)))); - ghost_share ghost_r (half n1, half (add_one n2)) (None, half (add_one n2)); + rewrite (GPR.pts_to ghost_r (half n1, full (add_one n2))) as + (GPR.pts_to ghost_r ((half n1, half (add_one n2)) `op pcm` (None, half (add_one n2)))); + GPR.share ghost_r (half n1, half (add_one n2)) (None, half (add_one n2)); fold ((lock_inv_ghost ghost_r) (v + 1)) }; - with _v. rewrite (ghost_pcm_pts_to ghost_r (G.reveal (G.hide _v))) as - (ghost_pcm_pts_to ghost_r _v); + with _v. rewrite (GPR.pts_to ghost_r (G.reveal (G.hide _v))) as + (GPR.pts_to ghost_r _v); share ghost_r; fold lock_inv_ghost; let l = L.new_lock (exists* v. pts_to r v ** lock_inv_ghost ghost_r v); @@ -739,14 +734,14 @@ fn incr_pcm_abstract (r:ref int) parallel requires L.lock_alive l #0.5R (exists* v. pts_to r v ** lock_inv_ghost ghost_r v) ** - ghost_pcm_pts_to ghost_r (half zero1, None) and + 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) ** - ghost_pcm_pts_to ghost_r (None, half zero1) + 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) ** - ghost_pcm_pts_to ghost_r (half (add_one zero1), None) and + 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) ** - ghost_pcm_pts_to ghost_r (None, half (add_one zero1)) + GPR.pts_to ghost_r (None, half (add_one 0)) { incr_pcm_t_abstract r l t1 } { incr_pcm_t_abstract r l t2 }; @@ -756,5 +751,5 @@ fn incr_pcm_abstract (r:ref int) unfold lock_inv_ghost; gather ghost_r; L.free l; - drop_ (ghost_pcm_pts_to ghost_r _) + drop_ (GPR.pts_to ghost_r _) } diff --git a/share/pulse/examples/by-example/PulseTutorial.Ref.fst b/share/pulse/examples/by-example/PulseTutorial.Ref.fst index 29e9d33e7..b949da803 100644 --- a/share/pulse/examples/by-example/PulseTutorial.Ref.fst +++ b/share/pulse/examples/by-example/PulseTutorial.Ref.fst @@ -30,7 +30,7 @@ ensures pts_to r ('v + 1) //end incr$ //swap$ -fn swap #a (r0 r1:ref a) +fn swap u#a (#a: Type u#a) (r0 r1:ref a) requires pts_to r0 'v0 ** pts_to r1 'v1 ensures pts_to r0 'v1 ** pts_to r1 'v0 { @@ -43,7 +43,7 @@ ensures pts_to r0 'v1 ** pts_to r1 'v0 //value_of$ -fn value_of (#a:Type) (r:ref a) +fn value_of u#a (#a:Type u#a) (r:ref a) requires pts_to r 'v returns v:a ensures pts_to r 'v ** pure (v == 'v) @@ -55,7 +55,7 @@ ensures pts_to r 'v ** pure (v == 'v) //value_of_explicit$ -fn value_of_explicit (#a:Type) (r:ref a) (#w:erased a) +fn value_of_explicit u#a (#a:Type u#a) (r:ref a) (#w:erased a) requires pts_to r w returns v:a ensures pts_to r w ** pure (v == reveal w) @@ -65,9 +65,9 @@ ensures pts_to r w ** pure (v == reveal w) //end value_of_explicit$ -[@@expect_failure] +[@@expect_failure [228]] //value_of_explicit_fail$ -fn value_of_explicit_fail (#a:Type) (r:ref a) (#w:erased a) +fn value_of_explicit_fail u#a (#a:Type u#a) (r:ref a) (#w:erased a) requires pts_to r w returns v:a ensures pts_to r w ** pure (v == reveal w) @@ -78,7 +78,7 @@ ensures pts_to r w ** pure (v == reveal w) //value_of_explicit_alt$ -fn value_of_explicit_alt (#a:Type) (r:ref a) (#w:erased a) +fn value_of_explicit_alt u#a (#a:Type u#a) (r:ref a) (#w:erased a) requires pts_to r w returns v:(x:a { x == reveal w } ) ensures pts_to r w @@ -90,7 +90,7 @@ ensures pts_to r w //assign$ -fn assign (#a:Type) (r:ref a) (v:a) +fn assign u#a (#a:Type u#a) (r:ref a) (v:a) requires pts_to r 'v ensures pts_to r v { @@ -157,7 +157,7 @@ ensures pts_to r (4 * 'v) //assign_1.0R$ -fn assign_full_perm (#a:Type) (r:ref a) (v:a) +fn assign_full_perm u#a (#a:Type u#a) (r:ref a) (v:a) requires pts_to r #1.0R 'v ensures pts_to r #1.0R v { @@ -167,7 +167,7 @@ ensures pts_to r #1.0R v //value_of_perm$ -fn value_of_perm #a #p (r:ref a) +fn value_of_perm u#a (#a: Type u#a) #p (r:ref a) requires pts_to r #p 'v returns v:a ensures pts_to r #p 'v ** pure (v == 'v) @@ -178,9 +178,9 @@ ensures pts_to r #p 'v ** pure (v == 'v) //assign_perm FAIL$ -[@@expect_failure] +[@@expect_failure [19]] -fn assign_perm #a #p (r:ref a) (v:a) (#w:erased a) +fn assign_perm u#a (#a: Type u#a) #p (r:ref a) (v:a) (#w:erased a) requires pts_to r #p w ensures pts_to r #p w { @@ -190,7 +190,7 @@ ensures pts_to r #p w //share_ref$ -fn share_ref #a #p (r:ref a) +fn share_ref u#a (#a: Type u#a) #p (r:ref a) requires pts_to r #p 'v ensures pts_to r #(p /. 2.0R) 'v ** pts_to r #(p /. 2.0R) 'v { @@ -200,7 +200,7 @@ ensures pts_to r #(p /. 2.0R) 'v ** pts_to r #(p /. 2.0R) 'v //gather_ref$ -fn gather_ref #a (#p:perm) (r:ref a) +fn gather_ref u#a (#a: Type u#a) (#p:perm) (r:ref a) requires pts_to r #(p /. 2.0R) 'v0 ** pts_to r #(p /. 2.0R) 'v1 @@ -214,7 +214,7 @@ ensures -fn max_perm #a (r:ref a) #p anything +fn max_perm u#a (#a: Type u#a) (r:ref a) #p anything requires pts_to r #p 'v ** pure (~ (p <=. 1.0R)) returns _:squash False ensures anything @@ -225,7 +225,7 @@ ensures anything //alias_ref$ -fn alias_ref #a #p (r:ref a) +fn alias_ref u#a (#a: Type u#a) #p (r:ref a) requires pts_to r #p 'v returns s:ref a ensures @@ -255,7 +255,7 @@ ensures pure (v == 1) //end one -[@@expect_failure] +[@@expect_failure [228]] //refs_as_scoped FAIL fn refs_are_scoped () requires emp diff --git a/share/pulse/examples/by-example/PulseTutorial.UserDefinedPredicates.fst b/share/pulse/examples/by-example/PulseTutorial.UserDefinedPredicates.fst index 1329649cb..50244fa3f 100644 --- a/share/pulse/examples/by-example/PulseTutorial.UserDefinedPredicates.fst +++ b/share/pulse/examples/by-example/PulseTutorial.UserDefinedPredicates.fst @@ -20,7 +20,7 @@ open Pulse.Lib.Pervasives open FStar.Mul //pts_to_diag$ let pts_to_diag - #a + (#a: Type0) (r:ref (a & a)) (v:a) : slprop diff --git a/share/pulse/examples/dice/dpe/DPE.fst b/share/pulse/examples/dice/dpe/DPE.fst index ecffa859b..208140952 100644 --- a/share/pulse/examples/dice/dpe/DPE.fst +++ b/share/pulse/examples/dice/dpe/DPE.fst @@ -80,9 +80,9 @@ fn initialize_global_state () returns x:(gref & mutex (option st)) ensures gvar_p x { - let r = ghost_alloc #_ #pcm all_sids_unused; - with _v. rewrite (ghost_pcm_pts_to r (G.reveal (G.hide _v))) as - (ghost_pcm_pts_to r _v); + let r = GR.alloc #_ #pcm all_sids_unused; + with _v. rewrite (GR.pts_to r (G.reveal (G.hide _v))) as + (GR.pts_to r _v); fold (dpe_inv r None); let m = new_mutex (dpe_inv r) None; fold (gvar_p (r, m)); @@ -99,9 +99,9 @@ let trace_ref = fst (Global.read_gvar_ghost gst) // // -// A wrapper over ghost_gather +// A wrapper over GR.gather // -// ghost_gather takes erased arguments, +// GR.gather takes erased arguments, // sometimes that leads to unnecessary reveals and hides // // This version works much better @@ -110,14 +110,14 @@ let trace_ref = fst (Global.read_gvar_ghost gst) ghost fn gather_ (r:gref) (v0 v1:pcm_t) - requires ghost_pcm_pts_to r v0 ** - ghost_pcm_pts_to r v1 + requires GR.pts_to r v0 ** + GR.pts_to r v1 returns _:squash (PCM.composable pcm v0 v1) - ensures ghost_pcm_pts_to r (PCM.op pcm v0 v1) + ensures GR.pts_to r (PCM.op pcm v0 v1) { - ghost_gather r v0 v1; - with _v. rewrite (ghost_pcm_pts_to r _v) as - (ghost_pcm_pts_to r (PCM.op pcm v0 v1)) + GR.gather r v0 v1; + with _v. rewrite (GR.pts_to r _v) as + (GR.pts_to r (PCM.op pcm v0 v1)) } @@ -132,15 +132,15 @@ fn gather_ (r:gref) ghost fn gather_v (r:gref) (v0 v1 v:pcm_t) - requires ghost_pcm_pts_to r v0 ** - ghost_pcm_pts_to r v1 ** + requires GR.pts_to r v0 ** + GR.pts_to r v1 ** pure (PCM.composable pcm v0 v1 ==> Map.equal (PCM.op pcm v0 v1) v) - ensures ghost_pcm_pts_to r v ** + ensures GR.pts_to r v ** pure (PCM.composable pcm v0 v1) { - ghost_gather r v0 v1; - with _v. rewrite (ghost_pcm_pts_to r _v) as - (ghost_pcm_pts_to r v) + GR.gather r v0 v1; + with _v. rewrite (GR.pts_to r _v) as + (GR.pts_to r v) } @@ -150,15 +150,15 @@ fn gather_v (r:gref) ghost fn share_ (r:gref) (v v0 v1:pcm_t) - requires ghost_pcm_pts_to r v ** + requires GR.pts_to r v ** pure (PCM.composable pcm v0 v1 /\ Map.equal (PCM.op pcm v0 v1) v) - ensures ghost_pcm_pts_to r v0 ** - ghost_pcm_pts_to r v1 + ensures GR.pts_to r v0 ** + GR.pts_to r v1 { - rewrite (ghost_pcm_pts_to r v) as - (ghost_pcm_pts_to r (PCM.op pcm v0 v1)); - ghost_share r v0 v1; + rewrite (GR.pts_to r v) as + (GR.pts_to r (PCM.op pcm v0 v1)); + GR.share r v0 v1; } @@ -203,7 +203,7 @@ fn upd_sid_pts_to fp (singleton sid 1.0R t0) sid; - ghost_write r + GR.write r (singleton sid 1.0R t0) (singleton sid 1.0R (next_trace t0 s)) fp; @@ -297,7 +297,7 @@ fn __open_session (s:st) with pht. assert (models tbl pht); assert (on_range (session_perm trace_ref pht) 0 (U16.v ctr)); - assert (ghost_pcm_pts_to trace_ref (sids_above_unused ctr)); + assert (GR.pts_to trace_ref (sids_above_unused ctr)); let copt = safe_incr ctr; @@ -379,8 +379,8 @@ fn maybe_mk_session_tbl (sopt:option st) unfold dpe_inv; assert (pure (Map.equal all_sids_unused (sids_above_unused s.st_ctr))); - rewrite (ghost_pcm_pts_to trace_ref all_sids_unused) as - (ghost_pcm_pts_to trace_ref (sids_above_unused s.st_ctr)); + rewrite (GR.pts_to trace_ref all_sids_unused) as + (GR.pts_to trace_ref (sids_above_unused s.st_ctr)); with pht. assert (models s.st_tbl pht); on_range_empty (session_perm trace_ref pht) 0; @@ -427,23 +427,23 @@ ghost fn gather_sid_pts_to (sid:sid_t) (#t0 #t1:trace) requires sid_pts_to trace_ref sid t0 ** sid_pts_to trace_ref sid t1 - ensures ghost_pcm_pts_to trace_ref (singleton sid 1.0R t0) ** + ensures GR.pts_to trace_ref (singleton sid 1.0R t0) ** pure (t0 == t1) { unfold (sid_pts_to trace_ref sid t0); unfold (sid_pts_to trace_ref sid t1); gather_ trace_ref (singleton sid 0.5R t0) (singleton sid 0.5R t1); - with v. assert (ghost_pcm_pts_to trace_ref v); + with v. assert (GR.pts_to trace_ref v); assert (pure (Map.equal v (singleton sid 1.0R t0))); - rewrite (ghost_pcm_pts_to trace_ref v) as - (ghost_pcm_pts_to trace_ref (singleton sid 1.0R t0)) + rewrite (GR.pts_to trace_ref v) as + (GR.pts_to trace_ref (singleton sid 1.0R t0)) } ghost fn share_sid_pts_to (sid:sid_t) (#t:trace) - requires ghost_pcm_pts_to trace_ref (singleton sid 1.0R t) + requires GR.pts_to trace_ref (singleton sid 1.0R t) ensures sid_pts_to trace_ref sid t ** sid_pts_to trace_ref sid t { @@ -461,8 +461,8 @@ fn upd_singleton (sid:sid_t) (#t:trace) (s:g_session_state { valid_transition t s }) - requires ghost_pcm_pts_to trace_ref (singleton sid 1.0R t) - ensures ghost_pcm_pts_to trace_ref (singleton sid 1.0R (next_trace t s)) + requires GR.pts_to trace_ref (singleton sid 1.0R t) + ensures GR.pts_to trace_ref (singleton sid 1.0R (next_trace t s)) { let fp : PCM.frame_preserving_upd trace_pcm (full t) (full (next_trace t s)) = mk_frame_preserving_upd t s; @@ -477,7 +477,7 @@ fn upd_singleton fp (singleton sid 1.0R t) sid; - ghost_write trace_ref + GR.write trace_ref (singleton sid 1.0R t) (singleton sid 1.0R (next_trace t s)) fp; @@ -530,7 +530,7 @@ fn replace_session (session_state_perm trace_ref pht0 sid); unfold session_state_perm; gather_sid_pts_to sid; - with t1. assert (ghost_pcm_pts_to trace_ref (singleton sid 1.0R t1)); + with t1. assert (GR.pts_to trace_ref (singleton sid 1.0R t1)); assert (pure (t1 == t)); let ret = HT.lookup tbl sid; let tbl = fst ret; diff --git a/share/pulse/examples/dice/dpe/DPE.fsti b/share/pulse/examples/dice/dpe/DPE.fsti index da0bc90f0..71c247d95 100644 --- a/share/pulse/examples/dice/dpe/DPE.fsti +++ b/share/pulse/examples/dice/dpe/DPE.fsti @@ -31,6 +31,7 @@ module U16 = FStar.UInt16 module U32 = FStar.UInt32 module PM = Pulse.Lib.PCM.Map module FP = Pulse.Lib.PCM.FractionalPreorder +module GR = Pulse.Lib.GhostPCMReference module A = Pulse.Lib.Array module PHT = Pulse.Lib.HashTable.Spec @@ -78,7 +79,7 @@ type st = { st_ctr:sid_t; st_tbl:ht_t; } // [@@ erasable] noeq -type g_session_state : Type u#1 = +type g_session_state : Type0 = | G_UnInitialized : g_session_state | G_SessionStart : g_session_state | G_Available : repr:context_repr_t -> g_session_state @@ -163,7 +164,7 @@ let rec well_formed_trace (l:list g_session_state) : prop = | _ -> False noextract -type trace_elt : Type u#1 = l:list g_session_state { well_formed_trace l } +type trace_elt : Type = l:list g_session_state { well_formed_trace l } noextract let trace_extension (t0 t1:trace_elt) : prop = @@ -177,7 +178,7 @@ noextract type trace = hist trace_preorder noextract -type trace_pcm_t : Type u#1 = FP.pcm_carrier trace_preorder +type trace_pcm_t : Type = FP.pcm_carrier trace_preorder // // Trace PCM is fractional preorder PCM, @@ -268,7 +269,7 @@ let full_perm_empty_history_compatible () : Lemma (FStar.PCM.compatible trace_pcm (Some 1.0R, []) (Some 1.0R, [])) = () noextract -type pcm_t : Type u#1 = PM.map sid_t trace_pcm_t +type pcm_t : Type = PM.map sid_t trace_pcm_t // // The PCM for the DPE state is a map pcm with sid_t keys @@ -278,7 +279,7 @@ let pcm : PCM.pcm pcm_t = PM.pointwise sid_t trace_pcm [@@ erasable] noextract -type gref = ghost_pcm_ref pcm +type gref = GR.gref pcm noextract let emp_trace : trace = [] @@ -293,7 +294,7 @@ let singleton (sid:sid_t) (p:perm) (t:trace) : GTot pcm_t = // noextract let sid_pts_to (r:gref) (sid:sid_t) (t:trace) : slprop = - ghost_pcm_pts_to r (singleton sid 0.5R t) + GR.pts_to r (singleton sid 0.5R t) noextract type pht_t = PHT.pht_t sid_t session_state @@ -351,7 +352,7 @@ let dpe_inv (r:gref) (s:option st) : slprop = // Global state is not initialized, // all the sessions are unused // - | None -> ghost_pcm_pts_to r all_sids_unused + | None -> GR.pts_to r all_sids_unused // // Global state has been initialized @@ -360,7 +361,7 @@ let dpe_inv (r:gref) (s:option st) : slprop = // // sids above counter are unused // - ghost_pcm_pts_to r (sids_above_unused s.st_ctr) ** + GR.pts_to r (sids_above_unused s.st_ctr) ** // // For sids below counter, we have the session state perm diff --git a/src/checker/Pulse.Extract.Main.fst b/src/checker/Pulse.Extract.Main.fst index cc217d458..74ec72340 100644 --- a/src/checker/Pulse.Extract.Main.fst +++ b/src/checker/Pulse.Extract.Main.fst @@ -414,6 +414,8 @@ let unit_binder (ppname: string) = qual = R.Q_Explicit; } +let small_type0 = tm_constant R.C_Unit + open Pulse.Syntax.Naming let rec extract_dv g (p:st_term) : T.Tac R.term = if is_erasable p then ECL.mk_return ECL.unit_tm @@ -482,8 +484,8 @@ let rec extract_dv g (p:st_term) : T.Tac R.term = | Tm_WithLocal { binder; initializer; body } -> let b' = extract_dv_binder binder None in - let allocator = R.mk_app (R.pack_ln (R.Tv_FVar (R.pack_fv ["Pulse"; "Lib"; "Reference"; "alloc"]))) - [get_type_of_ref binder.binder_ty, R.Q_Implicit; initializer, R.Q_Explicit] in + let allocator = R.mk_app (R.pack_ln (R.Tv_UInst (R.pack_fv ["Pulse"; "Lib"; "Reference"; "alloc"]) [u0])) + [get_type_of_ref binder.binder_ty, R.Q_Implicit; small_type0, R.Q_Explicit; initializer, R.Q_Explicit] in let g, x = extend_env'_binder g binder in let body = extract_dv g (open_st_term_nv body x) in ECL.mk_let b' allocator (close_term body x._2) @@ -495,8 +497,8 @@ let rec extract_dv g (p:st_term) : T.Tac R.term = // // This is parsed by Pulse2Rust // - let allocator = R.mk_app (R.pack_ln (R.Tv_FVar (R.pack_fv ["Pulse"; "Lib"; "Array"; "Core"; "alloc"]))) - [get_type_of_array binder.binder_ty, R.Q_Implicit; initializer, R.Q_Explicit; length, R.Q_Explicit] in + let allocator = R.mk_app (R.pack_ln (R.Tv_UInst (R.pack_fv ["Pulse"; "Lib"; "Array"; "PtsTo"; "alloc"]) [u0])) + [get_type_of_array binder.binder_ty, R.Q_Implicit; small_type0, R.Q_Explicit; initializer, R.Q_Explicit; length, R.Q_Explicit] in let g, x = extend_env'_binder g binder in let body = extract_dv g (open_st_term_nv body x) in ECL.mk_let b' allocator (close_term body x._2) diff --git a/src/checker/Pulse.Reflection.Util.fst b/src/checker/Pulse.Reflection.Util.fst index 90039aa4a..de7afc13d 100644 --- a/src/checker/Pulse.Reflection.Util.fst +++ b/src/checker/Pulse.Reflection.Util.fst @@ -629,7 +629,7 @@ let mk_rewrite (p q:R.term) = let mk_withlocal (ret_u:R.universe) (a init pre ret_t post body:R.term) = let open R in - let lid = mk_pulse_lib_reference_lid "with_local" in + let lid = mk_pulse_lib_reference_lid "with_local0" in let t = pack_ln (Tv_UInst (R.pack_fv lid) [ret_u]) in let t = pack_ln (Tv_App t (a, Q_Implicit)) in let t = pack_ln (Tv_App t (init, Q_Explicit)) in @@ -673,39 +673,41 @@ let pts_to_lid = mk_pulse_lib_reference_lid "pts_to" let mk_ref (a:R.term) : R.term = let open R in - let t = pack_ln (Tv_FVar (pack_fv ref_lid)) in + let t = pack_ln (Tv_UInst (pack_fv ref_lid) [uzero]) in pack_ln (Tv_App t (a, Q_Explicit)) let mk_pts_to (a:R.term) (r:R.term) (perm:R.term) (v:R.term) : R.term = let open R in - let t = pack_ln (Tv_FVar (pack_fv pts_to_lid)) in + let t = pack_ln (Tv_UInst (pack_fv pts_to_lid) [uzero]) in let t = pack_ln (Tv_App t (a, Q_Implicit)) in let t = pack_ln (Tv_App t (r, Q_Explicit)) in let t = pack_ln (Tv_App t (perm, Q_Implicit)) in pack_ln (Tv_App t (v, Q_Explicit)) let pulse_lib_array_core = ["Pulse"; "Lib"; "Array"; "Core"] +let pulse_lib_array_ptsto = ["Pulse"; "Lib"; "Array"; "PtsTo"] let mk_pulse_lib_array_core_lid s = pulse_lib_array_core @ [s] let array_lid = mk_pulse_lib_array_core_lid "array" -let array_pts_to_lid = mk_pulse_lib_array_core_lid "pts_to" +let array_pts_to_lid = pulse_lib_array_ptsto @ ["pts_to"] let array_length_lid = mk_pulse_lib_array_core_lid "length" let array_is_full_lid = mk_pulse_lib_array_core_lid "is_full_array" +let array_with_local_lid = pulse_lib_array_ptsto @ ["with_local"] let mk_array (a:R.term) : R.term = let open R in - let t = pack_ln (Tv_FVar (pack_fv array_lid)) in + let t = pack_ln (Tv_UInst (pack_fv array_lid) [uzero]) in pack_ln (Tv_App t (a, Q_Explicit)) let mk_array_length (a:R.term) (arr:R.term) : R.term = let open R in - let t = pack_ln (Tv_FVar (pack_fv array_length_lid)) in + let t = pack_ln (Tv_UInst (pack_fv array_length_lid) [uzero]) in let t = pack_ln (Tv_App t (a, Q_Implicit)) in pack_ln (Tv_App t (arr, Q_Explicit)) let mk_array_pts_to (a:R.term) (arr:R.term) (perm:R.term) (v:R.term) : R.term = let open R in - let t = pack_ln (Tv_FVar (pack_fv array_pts_to_lid)) in + let t = pack_ln (Tv_UInst (pack_fv array_pts_to_lid) [uzero]) in let t = pack_ln (Tv_App t (a, Q_Implicit)) in let t = pack_ln (Tv_App t (arr, Q_Explicit)) in let t = pack_ln (Tv_App t (perm, Q_Implicit)) in @@ -713,7 +715,7 @@ let mk_array_pts_to (a:R.term) (arr:R.term) (perm:R.term) (v:R.term) : R.term = // let mk_array_is_full (a:R.term) (arr:R.term) : R.term = // let open R in -// let t = pack_ln (Tv_FVar (pack_fv array_is_full_lid)) in +// let t = pack_ln (Tv_UInst (pack_fv array_is_full_lid) [uzero]) in // let t = pack_ln (Tv_App t (a, Q_Implicit)) in // pack_ln (Tv_App t (arr, Q_Explicit)) @@ -731,7 +733,7 @@ let mk_seq_create (u:R.universe) (a:R.term) (len:R.term) (v:R.term) : R.term = let mk_withlocalarray (ret_u:R.universe) (a init len pre ret_t post body:R.term) = let open R in - let lid = mk_pulse_lib_array_core_lid "with_local" in + let lid = array_with_local_lid in let t = pack_ln (Tv_UInst (R.pack_fv lid) [ret_u]) in let t = pack_ln (Tv_App t (a, Q_Implicit)) in let t = pack_ln (Tv_App t (init, Q_Explicit)) in diff --git a/src/checker/Pulse.Typing.fst b/src/checker/Pulse.Typing.fst index a57e215bf..943c0f754 100644 --- a/src/checker/Pulse.Typing.fst +++ b/src/checker/Pulse.Typing.fst @@ -87,10 +87,10 @@ let mk_sq_rewrites_to_p u t x y = mk_squash u_zero (R.mk_app hd args) -let mk_ref (t:term) : term = tm_pureapp (tm_fvar (as_fv ref_lid)) None t +let mk_ref (t:term) : term = tm_pureapp (tm_uinst (as_fv ref_lid) [u0]) None t let mk_pts_to (ty:term) (r:term) (v:term) : term = - let t = tm_fvar (as_fv pts_to_lid) in + let t = tm_uinst (as_fv pts_to_lid) [u0] in let t = tm_pureapp t (Some Implicit) ty in let t = tm_pureapp t None r in let t = tm_pureapp t (Some Implicit) tm_full_perm in @@ -472,22 +472,22 @@ let comp_withlocal_body (r:var) (init_t:term) (init:term) (c:comp{C_ST? c}) : co } let mk_array (a:term) : term = - tm_pureapp (tm_fvar (as_fv array_lid)) None a + tm_pureapp (tm_uinst (as_fv array_lid) [u0]) None a let mk_array_length (a:term) (arr:term) : term = - let t = tm_fvar (as_fv array_length_lid) in + let t = tm_uinst (as_fv array_length_lid) [u0] in let t = tm_pureapp t (Some Implicit) a in tm_pureapp t None arr let mk_array_pts_to (a:term) (arr:term) (v:term) : term = - let t = tm_fvar (as_fv array_pts_to_lid) in + let t = tm_uinst (as_fv array_pts_to_lid) [u0] in let t = tm_pureapp t (Some Implicit) a in let t = tm_pureapp t None arr in let t = tm_pureapp t (Some Implicit) tm_full_perm in tm_pureapp t None v // let mk_array_is_full (a:term) (arr:term) : term = -// let t = tm_fvar (as_fv array_is_full_lid) in +// let t = tm_uinst (as_fv array_is_full_lid) [u0] in // let t = tm_pureapp t (Some Implicit) a in // tm_pureapp t None arr diff --git a/src/extraction/ExtractPulse.fst b/src/extraction/ExtractPulse.fst index b6e739e83..622bd0603 100644 --- a/src/extraction/ExtractPulse.fst +++ b/src/extraction/ExtractPulse.fst @@ -35,8 +35,8 @@ let pulse_translate_type_without_decay : translate_type_without_decay_t = fun en match t with | MLTY_Named ([arg], p) when (let p = Syntax.string_of_mlpath p in - p = "Pulse.Lib.HigherReference.ref" || - p = "Pulse.Lib.HigherArray.Core.array" || + p = "Pulse.Lib.Reference.ref" || + p = "Pulse.Lib.Array.Core.array" || p = "Pulse.Lib.ArrayPtr.ptr" || p = "Pulse.Lib.Vec.vec" || p = "Pulse.Lib.Box.box") @@ -68,16 +68,16 @@ let pulse_translate_expr : translate_expr_t = fun env e -> (* Pulse references *) | MLE_App ({ expr = MLE_Name p } , [ _; init ]) | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) } , [ _; init ]) - when string_of_mlpath p = "Pulse.Lib.HigherReference.alloc" -> + when string_of_mlpath p = "Pulse.Lib.Reference.alloc" -> EBufCreate (Stack, cb init, EConstant (UInt32, "1")) | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, [ ty ] )}, [ _ ]) | MLE_TApp({ expr = MLE_Name p }, [ ty ] ) - when string_of_mlpath p = "Pulse.Lib.HigherReference.null" -> + when string_of_mlpath p = "Pulse.Lib.Reference.null" -> EBufNull (translate_type_without_decay env ty) | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, [ty]) } , [ r ]) - when string_of_mlpath p = "Pulse.Lib.HigherReference.is_null" -> + when string_of_mlpath p = "Pulse.Lib.Reference.is_null" -> generate_is_null (translate_type_without_decay env ty) (cb r) | MLE_App ({ expr = MLE_Name p } , [ init ]) @@ -100,20 +100,20 @@ let pulse_translate_expr : translate_expr_t = fun env e -> | MLE_App({expr=MLE_App({expr=MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e ])}, [_v])}, [_perm]) | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e; _v; _perm ]) - when string_of_mlpath p = "Pulse.Lib.HigherReference.read" + when string_of_mlpath p = "Pulse.Lib.Reference.read" || string_of_mlpath p = "Pulse.Lib.Box.op_Bang" -> EBufRead (cb e, zero_for_deref) | MLE_App ({expr=MLE_App({expr=MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e1 ])}, [e2])}, [_e3]) | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e1; e2; _e3 ]) - when string_of_mlpath p = "Pulse.Lib.HigherReference.write" + when string_of_mlpath p = "Pulse.Lib.Reference.write" || string_of_mlpath p = "Pulse.Lib.Box.op_Colon_Equals" -> 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.HigherArray.Core.mask_alloc" -> + when string_of_mlpath p = "Pulse.Lib.Array.Core.mask_alloc" -> EBufCreate (Stack, cb x, cb n) | MLE_App ({ expr = MLE_Name p }, [ x; n]) @@ -126,7 +126,7 @@ let pulse_translate_expr : translate_expr_t = fun env e -> EBufRead (cb e, cb i) | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e; i; _p; _w; _m ]) - when string_of_mlpath p = "Pulse.Lib.HigherArray.Core.mask_read" -> + when string_of_mlpath p = "Pulse.Lib.Array.Core.mask_read" -> EBufRead (cb e, cb i) | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e; i; v; _w ]) @@ -134,19 +134,19 @@ let pulse_translate_expr : translate_expr_t = fun env e -> EBufWrite (cb e, cb i, cb v) | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e; i; v; _; _ ]) - when string_of_mlpath p = "Pulse.Lib.HigherArray.Core.mask_write" -> + when string_of_mlpath p = "Pulse.Lib.Array.Core.mask_write" -> EBufWrite (cb e, cb i, cb v) | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ a; _p; _m; i; j; _w ]) - when string_of_mlpath p = "Pulse.Lib.HigherArray.Core.sub" -> + when string_of_mlpath p = "Pulse.Lib.Array.Core.sub" -> EBufSub (translate_expr env a, translate_expr env i) | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ r; _p; _w ]) - when string_of_mlpath p = "Pulse.Lib.HigherReference.to_array" -> + when string_of_mlpath p = "Pulse.Lib.Reference.to_array" -> translate_expr env r | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ a; i; _p; _w; _m ]) - when string_of_mlpath p = "Pulse.Lib.HigherReference.array_at" -> + when string_of_mlpath p = "Pulse.Lib.Reference.array_at" -> EBufSub (translate_expr env a, translate_expr env i) | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ x; _w ]) diff --git a/src/extraction/ExtractPulseOCaml.fst b/src/extraction/ExtractPulseOCaml.fst index a803e3a18..d8ad2cf21 100644 --- a/src/extraction/ExtractPulseOCaml.fst +++ b/src/extraction/ExtractPulseOCaml.fst @@ -52,10 +52,10 @@ let tr_typ (g:uenv) (t:term) : mlty = let Some (fv, us, args) = hua in // if !dbg then Format.print1 "GGG checking typ %s\n" (show hua); match fv, us, args with - | _, _, [(t, _)] when S.fv_eq_lid fv (Ident.lid_of_str "Pulse.Lib.HigherArray.Core.array") -> + | _, _, [(t, _)] when S.fv_eq_lid fv (Ident.lid_of_str "Pulse.Lib.Array.Core.array") -> MLTY_Named ([cb g t], ([], "array")) - | _, _, [(t, _)] when S.fv_eq_lid fv (Ident.lid_of_str "Pulse.Lib.HigherReference.ref") -> + | _, _, [(t, _)] when S.fv_eq_lid fv (Ident.lid_of_str "Pulse.Lib.Reference.ref") -> MLTY_Named ([cb g t], ([], "ref")) | _, _, [(t, _)] when S.fv_eq_lid fv (Ident.lid_of_str "Pulse.Lib.Box.box") -> MLTY_Named ([cb g t], ([], "ref")) @@ -117,20 +117,20 @@ let tr_expr (g:uenv) (t:term) : mlexpr & e_tag & mlty = e, E_PURE, mlty | _, _, [(t, _); _; (v0, None)] - when S.fv_eq_lid fv (Ident.lid_of_str "Pulse.Lib.HigherReference.alloc") -> + when S.fv_eq_lid fv (Ident.lid_of_str "Pulse.Lib.Reference.alloc") -> let mlty = term_as_mlty g t in let bang = with_ty ml_unit_ty <| MLE_Var "ref" in let e = with_ty mlty <| MLE_App (bang, [(cb g v0)._1]) in e, E_PURE, mlty | _, _, [(t, _); (v0, None)] - when S.fv_eq_lid fv (Ident.lid_of_str "Pulse.Lib.HigherReference.free") + when S.fv_eq_lid fv (Ident.lid_of_str "Pulse.Lib.Reference.free") || S.fv_eq_lid fv (Ident.lid_of_str "Pulse.Lib.Box.free") -> (* We translate 'free' as no-ops in OCaml. *) ml_unit, E_PURE, ml_unit_ty | _, _, [(t, _); (r, None); _n; _p] - when S.fv_eq_lid fv (Ident.lid_of_str "Pulse.Lib.HigherReference.read") + when S.fv_eq_lid fv (Ident.lid_of_str "Pulse.Lib.Reference.read") || S.fv_eq_lid fv (Ident.lid_of_str "Pulse.Lib.Box.op_Bang") -> let mlty = term_as_mlty g t in let bang = with_ty ml_unit_ty <| MLE_Var "!" in @@ -138,7 +138,7 @@ let tr_expr (g:uenv) (t:term) : mlexpr & e_tag & mlty = e, E_PURE, mlty | _, _, [(t, _); (r, None); (x, None); _n] - when S.fv_eq_lid fv (Ident.lid_of_str "Pulse.Lib.HigherReference.write") + when S.fv_eq_lid fv (Ident.lid_of_str "Pulse.Lib.Reference.write") || S.fv_eq_lid fv (Ident.lid_of_str "Pulse.Lib.Box.op_Colon_Equals") -> let mlty = term_as_mlty g t in let bang = with_ty ml_unit_ty <| MLE_Var "(:=)" in @@ -146,14 +146,14 @@ let tr_expr (g:uenv) (t:term) : mlexpr & e_tag & mlty = e, E_PURE, mlty | _, _, [(t, _); _; (x, None); (sz, None)] - when S.fv_eq_lid fv (Ident.lid_of_str "Pulse.Lib.HigherArray.Core.mask_alloc") -> + when S.fv_eq_lid fv (Ident.lid_of_str "Pulse.Lib.Array.Core.mask_alloc") -> 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 e, E_PURE, mlty | _, _, [(t, _); (a, None); (i, None); _p; _s; _m] - when S.fv_eq_lid fv (Ident.lid_of_str "Pulse.Lib.HigherArray.Core.mask_read") -> + when S.fv_eq_lid fv (Ident.lid_of_str "Pulse.Lib.Array.Core.mask_read") -> let mlty = term_as_mlty g t in let bang = with_ty ml_unit_ty <| MLE_Var "Array.get" in let a = (cb g a)._1 in @@ -164,7 +164,7 @@ let tr_expr (g:uenv) (t:term) : mlexpr & e_tag & mlty = e, E_PURE, mlty | _, _, [(t, _); (a, None); (i, None); (v, None); _s; _m] - when S.fv_eq_lid fv (Ident.lid_of_str "Pulse.Lib.HigherArray.Core.mask_write") -> + when S.fv_eq_lid fv (Ident.lid_of_str "Pulse.Lib.Array.Core.mask_write") -> let mlty = term_as_mlty g t in let bang = with_ty ml_unit_ty <| MLE_Var "Array.set" in let a = (cb g a)._1 in diff --git a/test/BorrowsExample.fst b/test/BorrowsExample.fst index eee2bd54e..94345c65b 100644 --- a/test/BorrowsExample.fst +++ b/test/BorrowsExample.fst @@ -12,7 +12,7 @@ open Pulse.Lib.WithPure let array_bpts_to #t (a: lifetime) (x: array t) (y: seq t) : slprop = exists* p. a >:> x |-> Frac p y -fn dup_array_bpts_to #t a x y () : duplicable_f (array_bpts_to #t a x y) = { +fn dup_array_bpts_to u#t (#t: Type u#t) a x y () : duplicable_f (array_bpts_to #t a x y) = { unfold array_bpts_to a x y; with p. _; intro (shift (pts_to x #p y) ((pts_to x #(p/.2.0R) y) ** (pts_to x #(p/.2.0R) y) ** trade ((pts_to x #(p/.2.0R) y) ** (pts_to x #(p/.2.0R) y)) (pts_to x #p y))) fn _ { @@ -28,7 +28,7 @@ fn dup_array_bpts_to #t a x y () : duplicable_f (array_bpts_to #t a x y) = { instance duplicable_array_bpts_to #t a x y : duplicable (array_bpts_to #t a x y) = { dup_f = dup_array_bpts_to #t a x y } inline_for_extraction noextract -unobservable fn array_slice #t #a (x: array t) (#y: erased (seq t)) i j +unobservable fn array_slice u#t (#t: Type u#t) #a (x: array t) (#y: erased (seq t)) i j preserves lifetime_alive a requires array_bpts_to a x y requires with_pure (SizeT.v i <= SizeT.v j /\ SizeT.v j < Seq.length y) @@ -57,7 +57,7 @@ unobservable fn array_slice #t #a (x: array t) (#y: erased (seq t)) i j } inline_for_extraction noextract -fn op_Array_Access #t #a (x: array t) (#y: erased (seq t)) (i: SizeT.t) +fn op_Array_Access u#t (#t: Type u#t) #a (x: array t) (#y: erased (seq t)) (i: SizeT.t) preserves lifetime_alive a preserves array_bpts_to a x y requires with_pure (SizeT.v i < Seq.length y) diff --git a/test/ExtractionTest.ml.expected b/test/ExtractionTest.ml.expected index cb80b3f4f..05b749ebe 100644 --- a/test/ExtractionTest.ml.expected +++ b/test/ExtractionTest.ml.expected @@ -1,46 +1,44 @@ open Prims let zero (uu___ : unit) : FStar_UInt32.t= Stdint.Uint32.zero let rec test_invariants_and_later (uu___ : unit) : unit= () -let rec test_read_write (x : FStar_UInt32.t Pulse_Lib_HigherReference.ref) +let rec test_read_write (x : FStar_UInt32.t Pulse_Lib_Reference.ref) (_'n : unit) : unit= - let n = Pulse_Lib_HigherReference.read x () () in - Pulse_Lib_HigherReference.write x (FStar_UInt32.add n Stdint.Uint32.zero) - () -let rec test_write_10 (x : FStar_UInt32.t Pulse_Lib_HigherReference.ref) + let n = Pulse_Lib_Reference.read x () () in + Pulse_Lib_Reference.write x (FStar_UInt32.add n Stdint.Uint32.zero) () +let rec test_write_10 (x : FStar_UInt32.t Pulse_Lib_Reference.ref) (_'n : unit) : unit= - Pulse_Lib_HigherReference.write x (Stdint.Uint32.of_int (2)) (); + Pulse_Lib_Reference.write x (Stdint.Uint32.of_int (2)) (); test_read_write x (); - Pulse_Lib_HigherReference.write x Stdint.Uint32.zero () + Pulse_Lib_Reference.write x Stdint.Uint32.zero () let rec test_inner_ghost_fun (uu___ : unit) : unit= () -let rec write10 (x : FStar_UInt32.t Pulse_Lib_HigherReference.ref) - (_'n : unit) : unit= - let ctr = Pulse_Lib_HigherReference.alloc () (Stdint.Uint32.of_int (10)) in +let rec write10 (x : FStar_UInt32.t Pulse_Lib_Reference.ref) (_'n : unit) : + unit= + let ctr = Pulse_Lib_Reference.alloc () (Stdint.Uint32.of_int (10)) in Pulse_Lib_Dv.while_ (fun while_cond -> - let __anf0 = Pulse_Lib_HigherReference.read ctr () () in + let __anf0 = Pulse_Lib_Reference.read ctr () () in FStar_UInt32.gt __anf0 Stdint.Uint32.zero) (fun while_body -> test_write_10 x (); - (let __anf0 = Pulse_Lib_HigherReference.read ctr () () in - Pulse_Lib_HigherReference.write ctr + (let __anf0 = Pulse_Lib_Reference.read ctr () () in + Pulse_Lib_Reference.write ctr (FStar_UInt32.sub __anf0 Stdint.Uint32.one) ())) -let rec fill_array (x : FStar_UInt32.t Pulse_Lib_HigherArray_Core.array) +let rec fill_array (x : FStar_UInt32.t Pulse_Lib_Array_Core.array) (n : FStar_SizeT.t) (v : FStar_UInt32.t) (_'s : unit) : unit= - let i = Pulse_Lib_HigherReference.alloc () Stdint.Uint64.zero in + let i = Pulse_Lib_Reference.alloc () Stdint.Uint64.zero in Pulse_Lib_Dv.while_ (fun while_cond -> - let __anf0 = Pulse_Lib_HigherReference.read i () () in + let __anf0 = Pulse_Lib_Reference.read i () () in FStar_SizeT.lt __anf0 n) (fun while_body -> - let __anf0 = Pulse_Lib_HigherReference.read i () () in - Pulse_Lib_HigherArray_Core.mask_write x __anf0 v () (); - (let __anf01 = Pulse_Lib_HigherReference.read i () () in - Pulse_Lib_HigherReference.write i + let __anf0 = Pulse_Lib_Reference.read i () () in + Pulse_Lib_Array_Core.mask_write x __anf0 v () (); + (let __anf01 = Pulse_Lib_Reference.read i () () in + Pulse_Lib_Reference.write i (FStar_SizeT.add __anf01 Stdint.Uint64.one) ())) -let rec sub_array (x : FStar_UInt32.t Pulse_Lib_HigherArray_Core.array) : - unit= - let __anf0 = Pulse_Lib_HigherArray_Core.sub x () () Stdint.Uint64.one () () in - Pulse_Lib_HigherArray_Core.mask_write __anf0 Stdint.Uint64.zero +let rec sub_array (x : FStar_UInt32.t Pulse_Lib_Array_Core.array) : unit= + let __anf0 = Pulse_Lib_Array_Core.sub x () () Stdint.Uint64.one () () in + Pulse_Lib_Array_Core.mask_write __anf0 Stdint.Uint64.zero (Stdint.Uint32.of_int (42)) () () let test0 (x : FStar_SizeT.t) (y : FStar_SizeT.t) : FStar_SizeT.t= FStar_SizeT.rem x y diff --git a/test/ImpureSpec.fst b/test/ImpureSpec.fst index 738ae9f36..ccbe9139b 100644 --- a/test/ImpureSpec.fst +++ b/test/ImpureSpec.fst @@ -26,7 +26,7 @@ fn test3 (r: ref int) assert (exists* v'. r |-> v') ** pure (!r > 17); // refers to v' from the exists! } -ghost fn array_val #t (r: array t) #p (#v: Seq.seq t) +ghost fn array_val u#a (#t: Type u#a) (r: array t) #p (#v: Seq.seq t) preserves r |-> Frac p v returns x: Seq.seq t ensures rewrites_to x v diff --git a/test/InlineArrayLen.ml.expected b/test/InlineArrayLen.ml.expected index e72053287..e6c2f933c 100644 --- a/test/InlineArrayLen.ml.expected +++ b/test/InlineArrayLen.ml.expected @@ -1,35 +1,33 @@ open Prims let rec basic (uu___ : unit) : FStar_Int32.t= let arr = - Pulse_Lib_HigherArray_Core.mask_alloc () (Stdint.Int32.of_int (123)) + Pulse_Lib_Array_Core.mask_alloc () (Stdint.Int32.of_int (123)) (Stdint.Uint64.of_int (2)) in - Pulse_Lib_HigherArray_Core.mask_read arr Stdint.Uint64.zero () () () + Pulse_Lib_Array_Core.mask_read arr Stdint.Uint64.zero () () () let rec use (uu___ : unit) : FStar_Int32.t= let arr = - Pulse_Lib_HigherArray_Core.mask_alloc () (Stdint.Int32.of_int (123)) + Pulse_Lib_Array_Core.mask_alloc () (Stdint.Int32.of_int (123)) (Stdint.Uint64.of_int (2)) in - Pulse_Lib_HigherArray_Core.mask_read arr Stdint.Uint64.zero () () () + Pulse_Lib_Array_Core.mask_read arr Stdint.Uint64.zero () () () let rec use_gen_init (uu___ : unit) : FStar_Int32.t= let arr = - Pulse_Lib_HigherArray_Core.mask_alloc () (Stdint.Int32.of_int (123)) + Pulse_Lib_Array_Core.mask_alloc () (Stdint.Int32.of_int (123)) (Stdint.Uint64.of_int (2)) in - Pulse_Lib_HigherArray_Core.mask_read arr Stdint.Uint64.zero () () () + 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_HigherArray_Core.mask_alloc () __anf0 - (Stdint.Uint64.of_int (2)) in - Pulse_Lib_HigherArray_Core.mask_read arr Stdint.Uint64.zero () () () + Pulse_Lib_Array_Core.mask_alloc () __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_HigherArray_Core.mask_alloc () (Stdint.Int32.of_int (123)) + Pulse_Lib_Array_Core.mask_alloc () (Stdint.Int32.of_int (123)) (Stdint.Uint64.of_int (2)) in - Pulse_Lib_HigherArray_Core.mask_read arr Stdint.Uint64.zero () () () + 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_HigherArray_Core.mask_alloc () (Stdint.Int32.of_int (123)) - __anf0 in - Pulse_Lib_HigherArray_Core.mask_read arr Stdint.Uint64.zero () () () + Pulse_Lib_Array_Core.mask_alloc () (Stdint.Int32.of_int (123)) __anf0 in + Pulse_Lib_Array_Core.mask_read arr Stdint.Uint64.zero () () () diff --git a/test/LetMutImps.fst b/test/LetMutImps.fst index d399dbfd0..7b75ec839 100644 --- a/test/LetMutImps.fst +++ b/test/LetMutImps.fst @@ -13,7 +13,7 @@ fn test () fn test2 () { - let mut p : ref int = null; + let mut p : ref u#0 int = null; (); } diff --git a/test/Null.ml.expected b/test/Null.ml.expected index f85b83239..c6ac4f299 100644 --- a/test/Null.ml.expected +++ b/test/Null.ml.expected @@ -1,10 +1,9 @@ open Prims -let x : Prims.int Pulse_Lib_HigherReference.ref= - Pulse_Lib_HigherReference.null () +let x : Prims.int Pulse_Lib_Reference.ref= Pulse_Lib_Reference.null () let y (uu___ : unit) : Prims.int Pulse_Lib_Box.box= Pulse_Lib_Box.null () let rec foo (uu___ : unit) : Prims.int Pulse_Lib_Box.box= Pulse_Lib_Box.null () -let rec test (x1 : Prims.int Pulse_Lib_HigherReference.ref) : Prims.int= - if Pulse_Lib_HigherReference.is_null x1 +let rec test (x1 : Prims.int Pulse_Lib_Reference.ref) : Prims.int= + if Pulse_Lib_Reference.is_null x1 then Prims.int_zero - else Pulse_Lib_HigherReference.read x1 () () + else Pulse_Lib_Reference.read x1 () () diff --git a/test/Test.ReflikeClass.fst b/test/Test.ReflikeClass.fst index e3dc12ab7..f37310a9d 100644 --- a/test/Test.ReflikeClass.fst +++ b/test/Test.ReflikeClass.fst @@ -14,7 +14,7 @@ class reflike (vt:Type) (rt:Type) = { } #push-options "--warn_error -288" -fn weakened_ref_alloc #a (x: a) +fn weakened_ref_alloc u#a (#a:Type u#a) {| small_type u#a |} (x: a) returns r: Pulse.Lib.Reference.ref a ensures Pulse.Lib.Reference.pts_to r x { @@ -22,7 +22,7 @@ fn weakened_ref_alloc #a (x: a) } (* Prevent warning about using alloc... this is just a test. *) -instance reflike_ref (a:Type) : reflike a (ref a) = { +instance reflike_ref (a:Type u#a) {| small_type u#a |} : reflike a (ref a) = { ( |-> ) = (fun r v -> Pulse.Lib.Reference.pts_to r v); alloc = weakened_ref_alloc; ( ! ) = (fun r #v0 -> Pulse.Lib.Reference.op_Bang r #v0 #1.0R); diff --git a/test/bug-reports/Bug267.fst b/test/bug-reports/Bug267.fst index 75f2ffb06..217cb9871 100644 --- a/test/bug-reports/Bug267.fst +++ b/test/bug-reports/Bug267.fst @@ -6,7 +6,7 @@ open FStar.Mul (* Complains that 'v is ghost, good. *) [@@expect_failure [228]] -fn value_of (#a:Type) (r:ref a) +fn value_of u#a (#a:Type u#a) (r:ref a) requires pts_to r 'v returns v:a ensures pts_to r 'v ** pure (v == 'v) diff --git a/test/bug-reports/Bug95b.fst b/test/bug-reports/Bug95b.fst index 91c8592f6..85d2d384b 100644 --- a/test/bug-reports/Bug95b.fst +++ b/test/bug-reports/Bug95b.fst @@ -15,8 +15,8 @@ let rec is_list_suffix ghost -fn intro_is_list_singleton - (#t:Type) +fn intro_is_list_singleton u#a + (#t:Type u#a) (x : ref t) (n : t) requires exists* (v:t).