Set Bullet Behavior "Strict Subproofs".
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.
Definition load_acq_spec := DECLARE _load_acq load_acq_spec.
Definition store_rel_spec := DECLARE _store_rel store_rel_spec.
Definition surely_malloc_spec :=
DECLARE _surely_malloc
WITH n:Z
PRE [ _n OF tuint ]
PROP (0 <= n <= Int.max_unsigned)
LOCAL (temp _n (Vint (Int.repr n)))
SEP ()
POST [ tptr tvoid ] EX p:_,
PROP ()
LOCAL (temp ret_temp p)
SEP (malloc_token Tsh n p * memory_block Tsh n p).
Definition tnode := Tstruct _node noattr.
Definition has_size : {x : Z | x = 8}.
Definition size := proj1_sig has_size.
(* Lexicographic ordering doesn't lead to a PCM (it's not associative), so we keep a full log of values. *)
(* In this example, all the resources held in the protocols are snapshots, so the full and read interpretations are equal. *)
(* This is a bit messy to allow the mutually recursive protocol interpretations. *)
Definition data_T' version version_T s (v : Z) := EX ver : Z, !!(Z.even ver = true /\ log_latest s ver v) &&
protocol_R version (ver - 1) Z.le (version_T, version_T).
Definition version_T_fun version locs g : (Z * Z -> mpred) -> (Z * Z -> mpred) :=
fun R '(s, v) => !!(v = s) && EX L : _,
!!(exists vs, Zlength vs = size /\ log_latest L (if Z.even v then v else v - 1) vs) &&
(if eq_dec v 0 then emp
else fold_right sepcon emp (map (fun i => protocol_R (Znth i locs Vundef) (map_Znth i L 0) map_incl
(data_T' version (fun s v => |>R (s, v)), data_T' version (fun s v => |>R (s, v)))) (upto (Z.to_nat size)))) *
ghost_snap L g.
Definition version_T' version locs g := HORec (version_T_fun version locs g).
Definition version_T version locs g s v := version_T' version locs g (s, v).
Definition data_T version locs g := data_T' version (|>version_T version locs g).
Instance data_prot version locs g : protocol (data_T version locs g) (data_T version locs g).
Instance version_prot version locs g : protocol (version_T version locs g) (version_T version locs g).
(* The collection of protocol assertions that describes a stable state of the node. *)
Definition node_state (sh : share) (L : Z -> option (list Z)) v version locs g :=
!!(Z.even v = true /\ 0 <= v /\ exists vs, Zlength vs = size /\ log_latest L v vs) &&
protocol_piece sh version v Z.le (version_T version locs g, version_T version locs g) *
fold_right sepcon emp (map (fun i => protocol_piece sh (Znth i locs Vundef) (map_Znth i L 0) map_incl
(data_T version locs g, data_T version locs g)) (upto (Z.to_nat size))) * ghost (sh, L) g.
Program Definition read_spec := DECLARE _read atomic_spec
(ConstType (val * val * share * share * val * list val * val * (Z -> option (list Z)) * Z))
empty_map [(_n, tptr tnode); (_out, tptr tint)] tvoid
[fun _ '(n, out, sh, shi, version, locs, g, L0, v0) => temp _n n;
fun _ '(n, out, sh, shi, version, locs, g, L0, v0) => temp _out out]
(fun _ '(n, out, sh, shi, version, locs, g, L0, v0) => !!(readable_share sh /\
writable_share shi /\ isptr version /\ Forall isptr locs /\ Zlength locs = size) &&
data_at sh tnode (version, locs) n * data_at_ shi (tarray tint size) out *
node_state Share.bot L0 v0 version locs g)
(fun _ '(n, out, sh, shi, version, locs, g, L0, v0) L => ghost (gsh1, L) g)
(0, []) []
(fun _ '(n, out, sh, shi, version, locs, g, L0, v0) L '(v, vals) =>
!!(v0 <= v /\ Zlength vals = size) &&
data_at sh tnode (version, locs) n * data_at shi (tarray tint size) (map (fun x => vint x) vals) out *
node_state Share.bot (map_upd L0 v vals) v version locs g)
(fun _ '(n, out, sh, shi, version, locs, g, L0, v0) L '(v, vals) => !!(map_incl L0 L /\ L v = Some vals) &&
ghost (gsh1, L) g)
_ _ _ _ _ _.
Next Obligation.
Next Obligation.
Next Obligation.
Next Obligation.
Next Obligation.
Next Obligation.
(* Because the "actual state" of the structure is divided between the writer and the invariant, a writer can make arbitrary updates to the ghost state and the data (without calling write). However, the protocols and the PCM constrain the nature of those updates to the sort of changes we'd expect anyway. *)
Program Definition write_spec := DECLARE _write atomic_spec
(ConstType (val * val * share * share * val * list val * list Z * val * (Z -> option (list Z)) * Z))
(@empty_map Z (list Z)) [(_n, tptr tnode); (_in, tptr tint)] tvoid
[fun _ '(n, input, sh, shi, version, locs, vals, g, L, v0) => temp _n n;
fun _ '(n, input, sh, shi, version, locs, vals, g, L, v0) => temp _in input]
(fun _ '(n, input, sh, shi, version, locs, vals, g, L, v0) => !!(readable_share sh /\
readable_share shi /\ isptr version /\ Forall isptr locs /\ Zlength locs = size /\
Forall repable_signed vals /\ repable_signed (v0 + 2)) &&
data_at sh tnode (version, locs) n * data_at shi (tarray tint size) (map (fun x => vint x) vals) input *
node_state gsh2 L v0 version locs g)
(fun _ '(n, input, sh, shi, version, locs, vals, g, L, v0) L' => ghost (gsh1, L') g)
tt []
(fun _ '(n, input, sh, shi, version, locs, vals, g, L, v0) _ _ =>
data_at sh tnode (version, locs) n * data_at shi (tarray tint size) (map (fun x => vint x) vals) input *
node_state gsh2 (map_upd L (v0 + 2) vals) (v0 + 2) version locs g)
(fun _ '(n, input, sh, shi, version, locs, vals, g, L, v0) _ _ => ghost (gsh1, map_upd L (v0 + 2) vals) g)
_ _ _ _ _ _.
Next Obligation.
Next Obligation.
Next Obligation.
Next Obligation.
Next Obligation.
Next Obligation.
Definition make_node_spec := DECLARE _make_node
WITH u : unit
PRE [ ]
PROP ()
LOCAL ()
SEP ()
POST [ tptr tnode ]
EX n : val, EX version : val, EX locs : list val, EX g : val,
PROP (isptr version; Forall isptr locs; Zlength locs = size)
LOCAL (temp ret_temp n)
SEP (data_at Tsh tnode (version, locs) n; malloc_token Tsh (sizeof tnode) n;
malloc_token Tsh (sizeof tint) version; fold_right sepcon emp (map (malloc_token Tsh (sizeof tint)) locs);
node_state gsh2 (singleton 0 (repeat 0 (Z.to_nat size))) 0 version locs g;
ghost (gsh1, singleton 0 (repeat 0 (Z.to_nat size))) g).
Definition writer_spec := DECLARE _writer
WITH n : val, sh : share, v : Z, L : Z -> option (list Z), version : val, locs : list val, g : val
PRE [ _n OF tptr tvoid ]
PROP (readable_share sh; isptr version; Forall isptr locs; Zlength locs = size; repable_signed (v + 6))
LOCAL (temp _n n)
SEP (data_at sh tnode (version, locs) n; node_state gsh2 L v version locs g;
invariant (EX L : Z -> option (list Z), ghost (gsh1, L) g))
POST [ tptr tvoid ]
EX L' : _,
PROP (L' = map_upd_list L (map (fun i => (v + (2 * (i + 1)), repeat (i + 1) (Z.to_nat size)))%Z (upto 3)))
LOCAL ()
SEP (data_at sh tnode (version, locs) n; node_state gsh2 L' (v + 6) version locs g;
invariant (EX L : Z -> option (list Z), ghost (gsh1, L) g)).
(*Definition reader_spec := DECLARE _reader WITH n : val, sh : share, version : val, locs : list val, g : val, g' : val, lg : list val, lg' : list val, gh : val, gsh : share PRE [ _n OF tptr tvoid ] PROP (readable_share sh; isptr version; Forall isptr locs; Zlength locs = size; gsh <> Share.bot) LOCAL (temp _n n) SEP (data_at sh tnode (version, locs) n; ghost_hist gsh ([] : hist) gh; invariant (node_inv gh version locs g g' lg lg')) POST [ tptr tvoid ] EX h : hist, PROP (exists v vs, add_events [] [HRead v vs] h) LOCAL () SEP (data_at sh tnode (version, locs) n; ghost_hist gsh h gh; invariant (node_inv gh version locs g g' lg lg')).*)
(* We can't keep an interleaved history of reads and writes, but we can know that each read got a value that was at some point in the history. *)
(*Program Definition reader_spec := DECLARE _reader atomic_spec (ConstType (val * share * val * list val * val * val * list val * list val * val * share)) tt [(_n, tptr tvoid)] (tptr tvoid) [fun _ '(n, sh, version, locs, g, g', lg, lg', gh, gsh) => temp _n n] (fun _ '(n, sh, version, locs, g, g', lg, lg', gh, gsh) => !!(readable_share sh /\ isptr version /\ Forall isptr locs /\ Zlength locs = size /\ gsh <> Share.bot) && data_at sh tnode (version, locs) n) (fun _ '(n, sh, version, locs, g, g', lg, lg', gh, gsh) _ => node_inv gh version locs g g' lg lg') (0, []) [] (fun _ '(n, sh, version, locs, g, g', lg, lg', gh, gsh) _ _ => data_at sh tnode (version, locs) n) (fun _ '(n, sh, version, locs, g, g', lg, lg', gh, gsh) _ '(v1, vs1) => EX v : Z, EX vs : list Z, node_state v vs version locs g g' lg lg' * EX hr : _, !!(apply_hist (0, repeat 0 (Z.to_nat size)) hr = Some (v, vs) /\ In (HWrite v1 vs1) hr) && ghost_ref hr gh) _ _ _ _ _ _. (* We could encapsulate this with another argument to node_inv, a known sublist of hr. *)*)
Definition reader_spec := DECLARE _reader
WITH n : val, sh : share, v : Z, L : Z -> option (list Z), version : val, locs : list val, g : val
PRE [ _n OF tptr tvoid ]
PROP (readable_share sh; isptr version; Forall isptr locs; Zlength locs = size)
LOCAL (temp _n n)
SEP (data_at sh tnode (version, locs) n; node_state Share.bot L v version locs g;
invariant (EX L : Z -> option (list Z), ghost (gsh1, L) g))
POST [ tptr tvoid ]
EX v' : Z, EX vs' : list Z,
PROP (v <= v'; v' = v -> Z.even v = true /\ L v = Some vs')
LOCAL ()
SEP (data_at sh tnode (version, locs) n; node_state Share.bot (map_upd L v' vs') v' version locs g;
invariant (EX L : Z -> option (list Z), ghost (gsh1, L) g)).
Definition Gprog : funspecs := ltac:(with_library prog [surely_malloc_spec; load_acq_spec; store_rel_spec;
read_spec; write_spec; make_node_spec; writer_spec; reader_spec]).
Definition list_max v l := fold_right Z.max v l.

(* Since the public view of the data structure has no data content (it's just the ghost state), there's no need for the backing-out linearization point reasoning (and in fact the linearization point can be anywhere, since all new write really guarantees is that no other data will be written at that version, plus maybe a certain eventual consistency). *)
Lemma body_write : semax_body Vprog Gprog f_write write_spec.