Set Bullet Behavior "Strict Subproofs".
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.
Definition makelock_spec := DECLARE _makelock (makelock_spec _).
Definition freelock2_spec := DECLARE _freelock2 (freelock2_spec _).
Definition acquire_spec := DECLARE _acquire acquire_spec.
Definition release2_spec := DECLARE _release2 release2_spec.
Definition spawn_spec := DECLARE _spawn spawn_spec.
Definition load_acq_spec := DECLARE _load_acq load_acq_spec.
(*Definition store_rel_spec := DECLARE _store_rel store_rel_spec'.*)
Definition CAS_RA_spec := DECLARE _CAS_RA CAS_RA_spec.
Definition surely_malloc_spec :=
DECLARE _surely_malloc
WITH t : type, gv : globals
PRE [ _n OF tuint ]
PROP (0 <= sizeof t <= Int.max_unsigned; complete_legal_cosu_type t = true;
natural_aligned natural_alignment t = true)
LOCAL (temp _n (Vint (Int.repr (sizeof t))); gvars gv)
SEP (mem_mgr gv)
POST [ tptr tvoid ] EX p:_,
PROP ()
LOCAL (temp ret_temp p)
SEP (mem_mgr gv; malloc_token Ews t p; data_at_ Ews t p).
Definition integer_hash_spec :=
DECLARE _integer_hash
WITH i : Z
PRE [ _i OF tint ]
PROP () LOCAL (temp _i (vint i)) SEP ()
POST [ tint ]
PROP () LOCAL (temp ret_temp (vint (i * 654435761))) SEP ().
(* One might think it should just return an unknown number, but in fact it needs to follow a known hash function at the logic level to be useful. *)
Definition tentry := Tstruct _entry noattr.
(* Having size as a large known constant tends to make everything slow, so here's a hack. *)
Definition has_size : {x : Z | x = 16384}.
Instance hf1 : hash_fun := { size := proj1_sig has_size; hash i := (i * 654435761) mod (proj1_sig has_size) }.
Hint Resolve value_of_0.
(* If we're going to do a store_rel to a location, we can't expect to get resources out of it. In fact, unless we CAS, Tfull is *only* an obligation, not an available resource. *)
(* This definition is unsuitable for set_item (because it has a nontrivial full interpretation), and weaker than useful for the other functions. Definition v_T sh g s (v : Z) := EX log : Z -> option Z, !!(s = v /\ value_of log v) && ghost (sh, log) g. *)
Definition v_T sh g s (v : Z) := !!(value_of s v /\ (v = 0 -> forall j v', s j = Some v' -> v' = 0)) &&
@ghost_master _ _ fmap_order sh s g.
Instance v_prot g : protocol (v_T Share.bot g) (v_T gsh2 g).
Notation v_T' g := (v_T Share.bot g, v_T gsh2 g).
Notation v_state i lg l s := (protocol_A l s map_incl (v_T' (Znth i lg))).
(* We don't need histories for keys, but we do need to know that a non-zero key is persistent. *)
Definition zero_ord a b := a = 0 \/ a = b.
Instance zero_RA : Ghost := { valid a := True;
Join_G a b c := if eq_dec a 0 then c = b else a = c /\ zero_ord b c }.
Definition k_T (sh : share) g s v := !!(s = v) && ghost_master sh v g.
Instance k_prot g : protocol (k_T Share.bot g) (k_T gsh2 g).
Notation k_T' g := (k_T Share.bot g, k_T gsh2 g).
Notation k_state i lg l s := (protocol_A l s zero_ord (k_T' (Znth i lg))).
(* lookup doesn't really depend on the type of values. *)
Definition lookup' {B} (T : list (Z * B)) := lookup (combine (map fst T) (repeat 0 (Z.to_nat size))).
Definition wf_table (T : list (Z * (nat -> option Z))) := forall k i, k <> 0 -> fst (Znth i T) = k ->
lookup' T k = Some i.
Definition hashtable_entry (T : list (Z * (_ -> option Z))) lgk lgv i :=
let '(k, lv) := Znth i T in !!(exists v, value_of lv v /\ (k = 0 -> v = 0) /\
(v = 0 -> forall j v', lv j = Some v' -> v' = 0)) &&
ghost_master gsh1 k (Znth i lgk) * @ghost_master _ _ fmap_order gsh1 lv (Znth i lgv).
Existing Instance exclusive_PCM.
(* The hashtable assertion contains all the ghost state of the SC version, but no data; the protocols enforce the relationship between the ghost state and the data. *)
Definition hashtable H g lgk lgv := EX T : list (Z * (nat -> option Z)),
!!(Zlength T = size /\ wf_table T /\
forall k lv, H k = Some lv <-> In (k, lv) T /\ exists v, value_of lv v /\ v <> 0) &&
excl g H * fold_right sepcon emp (map (hashtable_entry T lgk lgv) (upto (Z.to_nat size))).
Definition hashtable_entry_A T lgk lgv entries i := let '(pk, pv) := Znth i entries in
let '(k, lv) := Znth i T in !!(exists v, value_of lv v /\ (k = 0 -> v = 0) /\
(v = 0 -> forall j v', lv j = Some v' -> v' = 0)) && k_state i lgk pk k * v_state i lgv pv lv.
Definition hashtable_A T lgk lgv entries :=
fold_right sepcon emp (map (hashtable_entry_A T lgk lgv entries) (upto (Z.to_nat size))).
Definition HT_upd (H : Z -> option (_ -> option Z)) k v H' := exists lv, H' = map_upd H k lv /\ value_of lv v /\
match H k with Some lv0 => map_incl lv0 lv | None => True end.
Definition table_incl (T1 T2 : list (Z * (nat -> option Z))) := forall i,
zero_ord (fst (Znth i T1)) (fst (Znth i T2)) /\
map_incl (snd (Znth i T1)) (snd (Znth i T2)).
(*Program Definition set_item_spec := DECLARE _set_item atomic_spec (ConstType (Z * Z * val * share * list (val * val) * gname * list gname * list gname * list (Z * (Z -> option Z)))) [(_key, tint); (_value, tint)] tvoid [fun _ '(k, v, p, sh, entries, g, lgk, lgv, T0) => temp _key (vint k); fun _ '(k, v, p, sh, entries, g, lgk, lgv, T0) => temp _value (vint v); fun _ '(k, v, p, sh, entries, g, lgk, lgv, T0) => gvar _m_entries p] (fun _ '(k, v, p, sh, entries, g, lgk, lgv, T0) => !!(readable_share sh /\ repable_signed k /\ repable_signed v /\ k <> 0 /\ v <> 0 /\ Forall (fun '(pk, pv) => isptr pk /\ isptr pv) entries /\ Zlength lgk = size /\ Zlength lgv = size /\ Zlength T0 = size(* /\ wf_table T0*)) && data_at sh (tarray tentry size) entries p * hashtable_A T0 lgk lgv entries) (fun _ '(k, v, p, sh, entries, g, lgk, lgv, T0) H => hashtable H g lgk lgv) tt [] (fun _ '(k, v, p, sh, entries, g, lgk, lgv, T0) H _ => data_at sh (tarray tentry size) entries p * EX T : _, !!(table_incl T0 T /\ Zlength T = size /\ (*wf_table T /\*) exists i lv, lookup' T k = Some i /\ Znth i T = (k, lv) /\ value_of lv v) && hashtable_A T lgk lgv entries) (fun _ '(k, v, p, sh, entries, g, lgk, lgv, T0) H _ => EX H' : _, !!(HT_upd H k v H') && hashtable H' g lgk lgv) _ _ _ _ _ _. Next Obligation. Next Obligation. Next Obligation. Next Obligation. Next Obligation. Next Obligation.  (* get_item_spec must be more relaxed. Reading a 0 doesn't guarantee the key is absent, and the value read can be arbitrarily outdated. *)
Program Definition get_item_spec := DECLARE _get_item atomic_spec
(ConstType (Z * globals * share * list (val * val) * gname * list gname * list gname * list (Z * (_ -> option Z))))
[(_key, tint)] tint
[fun _ '(k, gv, sh, entries, g, lgk, lgv, T0) => temp _key (vint k);
fun _ '(k, gv, sh, entries, g, lgk, lgv, T0) => gvars gv]
(fun _ '(k, gv, sh, entries, g, lgk, lgv, T0) => !!(readable_share sh /\ repable_signed k /\ k <> 0 /\
Forall (fun '(pk, pv) => isptr pk /\ isptr pv) entries /\ Zlength lgk = size /\ Zlength lgv = size /\
Zlength T0 = size (*/\ wf_table T0*)) &&
data_at sh (tarray tentry size) entries (gv _m_entries) * hashtable_A T0 lgk lgv entries)
(fun _ '(k, gv, sh, entries, g, lgk, lgv, T0) H => hashtable H g lgk lgv)
(0, empty_map) [fun _ _ x => temp ret_temp (vint (fst x))]
(fun _ '(k, gv, sh, entries, g, lgk, lgv, T0) H '(v, lv) => (data_at sh (tarray tentry size) entries (gv _m_entries) *
EX T : _, !!(table_incl T0 T /\ Zlength T = size /\ (*wf_table T /\*) exists i,
lookup' T k = Some i /\ snd (Znth i T) = lv) && hashtable_A T lgk lgv entries) *
(!!(value_of lv v /\ (v <> 0 -> exists lv', H k = Some lv' /\ map_incl lv lv')) &&
hashtable H g lgk lgv)) (Empty_set _) (Full_set _) _ _ _ _ _.
Next Obligation.
Next Obligation.
Next Obligation.
Next Obligation.
Next Obligation.
Program Definition add_item_spec := DECLARE _add_item atomic_spec
(ConstType (Z * Z * globals * share * list (val * val) * gname * list gname * list gname * list (Z * (_ -> option Z))))
[(_key, tint); (_value, tint)] tint
[fun _ '(k, v, gv, sh, entries, g, lgk, lgv, T0) => temp _key (vint k);
fun _ '(k, v, gv, sh, entries, g, lgk, lgv, T0) => temp _value (vint v);
fun _ '(k, v, gv, sh, entries, g, lgk, lgv, T0) => gvars gv]
(fun _ '(k, v, gv, sh, entries, g, lgk, lgv, T0) => !!(readable_share sh /\ repable_signed k /\ repable_signed v /\
k <> 0 /\ v <> 0 /\ Forall (fun '(pk, pv) => isptr pk /\ isptr pv) entries /\ Zlength lgk = size /\ Zlength lgv = size /\
Zlength T0 = size (*/\ wf_table T0*)) &&
data_at sh (tarray tentry size) entries (gv _m_entries) * hashtable_A T0 lgk lgv entries)
(fun _ '(k, v, gv, sh, entries, g, lgk, lgv, T0) H => hashtable H g lgk lgv)
(true, empty_map) [fun _ _ x => temp ret_temp (Val.of_bool (fst x))]
(fun _ '(k, v, gv, sh, entries, g, lgk, lgv, T0) H '(b, lv) => (data_at sh (tarray tentry size) entries (gv _m_entries) *
EX T : _, !!(table_incl T0 T /\ Zlength T = size (*/\ wf_table T*) /\ exists i, lookup' T k = Some i /\
Znth i T = (k, lv)) && hashtable_A T lgk lgv entries) *
(!!((H k = None <-> b = true) /\ (b = true -> value_of lv v)) &&
hashtable (if b then map_upd H k lv else H) g lgk lgv)) (Empty_set _) (Full_set _) _ _ _ _ _.
Next Obligation.
Next Obligation.
Next Obligation.
Next Obligation.
Next Obligation.
Definition init_table_spec :=
DECLARE _init_table
WITH gv : globals
PRE [ ]
PROP ()
LOCAL (gvars gv)
SEP (mem_mgr gv; data_at_ Ews (tarray tentry size) (gv _m_entries))
POST [ tvoid ]
EX entries : list (val * val), EX g : gname, EX lgk : list gname, EX lgv : list gname,
PROP (Forall (fun '(pk, pv) => isptr pk /\ isptr pv) entries; Zlength lgk = size; Zlength lgv = size)
LOCAL ()
SEP (mem_mgr gv; data_at Ews (tarray tentry size) entries (gv _m_entries); fold_right sepcon emp (map (fun '(pk, pv) =>
malloc_token Ews tint pk * malloc_token Ews tint pv) entries);
hashtable (fun _ => None) g lgk lgv;
hashtable_A (repeat (0, singleton O 0) (Z.to_nat size)) lgk lgv entries).
Inductive hashtable_hist_el :=
| HSet (k : Z) (v : Z) | HGet (k : Z) (v : Z) | HAdd (k : Z) (v : Z) (r : bool).
Notation hist := (list (nat * hashtable_hist_el)).
Fixpoint apply_hist H h H' :=
match h with
| [] => H' = H
| HSet k v :: h' => exists H1, HT_upd H k v H1 /\ apply_hist H1 h' H'
| HGet k v :: h' => (v <> 0 -> exists lv, H k = Some lv /\ exists j, lv j = Some v) /\ apply_hist H h' H'
| HAdd k v r :: h' => if r then H k = None /\ exists H1, HT_upd H k v H1 /\ apply_hist H1 h' H'
else H k <> None /\ apply_hist H h' H'
end.
Definition hashtable_inv gh g lgk lgv := EX H : _, hashtable H g lgk lgv *
EX hr : _, !!(apply_hist (fun _ => None) hr H) && ghost_ref hr gh.
Definition f_lock_inv N gv sh gsh entries gh g lgk lgv t lockt res (inv_names : invG) :=
EX b1 : bool, EX b2 : bool, EX b3 : bool, EX h : _,
!!(add_events empty_map [HAdd 1 1 b1; HAdd 2 1 b2; HAdd 3 1 b3] h) && ghost_hist gsh h gh *
mem_mgr gv * data_at sh (tarray tentry size) entries (gv _m_entries) *
invariant N (hashtable_inv gh g lgk lgv) * (EX T : _, hashtable_A T lgk lgv entries) *
data_at sh (tarray (tptr tlock) 3) (upd_Znth t (repeat Vundef 3) lockt) (gv _thread_locks) *
data_at sh (tarray (tptr tint) 3) (upd_Znth t (repeat Vundef 3) res) (gv _results) *
data_at Ews tint (vint (Zlength (filter id [b1; b2; b3]))) res.
Definition f_lock_pred N gv tsh sh gsh entries gh g lgk lgv t lockt res inv_names :=
selflock (f_lock_inv N gv sh gsh entries gh g lgk lgv t lockt res inv_names) tsh lockt.
Definition f_spec :=
DECLARE _f
WITH tid : val, x : iname * share * share * share * list (val * val) * gname * gname *
list gname * list gname * globals * Z * val * val * invG
PRE [ _arg OF (tptr tvoid) ]
let '(N, sh, gsh, tsh, entries, gh, g, lgk, lgv, gv, t, lockt, res, inv_names) := x in
PROP (0 <= t < 3; isptr lockt; readable_share sh; readable_share tsh; gsh <> Share.bot;
Forall (fun '(pk, pv) => isptr pk /\ isptr pv) entries; Zlength lgk = size; Zlength lgv = size)
LOCAL (temp _arg tid; gvars gv)
SEP (mem_mgr gv; data_at sh (tarray tentry size) entries (gv _m_entries); invariant N (hashtable_inv gh g lgk lgv);
hashtable_A (repeat (0, singleton O 0) (Z.to_nat size)) lgk lgv entries;
ghost_hist(hist_el := hashtable_hist_el) gsh empty_map gh;
data_at Ews tint (vint t) tid; malloc_token Ews tint tid;
data_at sh (tarray (tptr tlock) 3) (upd_Znth t (repeat Vundef 3) lockt) (gv _thread_locks);
data_at sh (tarray (tptr tint) 3) (upd_Znth t (repeat Vundef 3) res) (gv _results);
data_at_ Ews tint res;
lock_inv tsh lockt (f_lock_pred N gv tsh sh gsh entries gh g lgk lgv t lockt res inv_names))
POST [ tptr tvoid ] PROP () LOCAL () SEP ().
Definition main_spec :=
DECLARE _main
WITH gv : globals
PRE  [] main_pre prog nil gv
POST [ tint ] main_post prog nil gv.
Definition Gprog : funspecs := ltac:(with_library prog [makelock_spec; freelock2_spec; acquire_spec;
release2_spec; spawn_spec; surely_malloc_spec; load_acq_spec; CAS_RA_spec;
integer_hash_spec; get_item_spec; add_item_spec; init_table_spec; f_spec; main_spec]).
Opaque upto.
Hint Resolve zero_ord_0.
Arguments size : simpl never.
Arguments hash : simpl never.
(* Why isn't this automatic? *)
Instance zero_ord_preorder : RelationClasses.PreOrder zero_ord.
Instance table_incl_preorder : RelationClasses.PreOrder table_incl.
Opaque Znth.
Hint Resolve f_pred_exclusive.

Lemma apply_hist_app : forall h1 h2 H H', apply_hist H (h1 ++ h2) H' <->
exists H1, apply_hist H h1 H1 /\ apply_hist H1 h2 H'.