Set Bullet Behavior "Strict Subproofs".
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.
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 tentry := Tstruct _entry noattr.
Definition entry_hists entries hists := fold_right_sepcon (map (fun i =>
let '(hp, e) := (Znth i hists ([], []), Znth i entries Vundef) in
ghost_hist (fst hp) (field_address tentry [StructField _key] e) *
ghost_hist (snd hp) (field_address tentry [StructField _value] e)) (upto 20)).
(* In this case, let map be an association list. *)
Fixpoint index_of (m : list (Z * Z)) (k : Z) :=
match m with
| [] => None
| (k1, v1) :: rest => if eq_dec k1 k then Some 0
else option_map Z.succ (index_of rest k)
end.
Definition set m k v :=
match index_of m k with
| Some i => upd_Znth i m (k, v)
| None => m ++ [(k, v)]
end.
Definition get m k := option_map (fun i => snd (Znth i m (0, 0))) (index_of m k).
Definition value_of e :=
match e with
| Load v => v
| Store v => v
| CAS r c w => if eq_dec r c then w else r
end.
Definition last_value (h : hist) v :=
(* initial condition *)
(h = [] /\ v = vint 0) \/
exists n e, In (n, e) h /\ value_of e = v /\ Forall (fun x => let '(m, _) := x in m <= n)%nat h.
Definition ordered_hist h := forall i j (Hi : 0 <= i < j) (Hj : j < Zlength h),
(fst (Znth i h (O, Store (vint 0))) < fst (Znth j h (O, Store (vint 0))))%nat.
Definition value_of_hist (h : hist) := value_of (snd (last h (O, Store (vint 0)))).
Definition wf_map (m : list (Z * Z)) := Forall (fun i => repable_signed i /\ i <> 0) (map fst m).
Definition int_op e :=
match e with
| Load v | Store v => tc_val tint v
| CAS r c w => tc_val tint r /\ tc_val tint c /\ tc_val tint w
end.
(* Once set, a key is never reset. *)
Definition k_R (h : list hist_el) (v : val) := !!(Forall int_op h /\
forall e, In e h -> value_of e <> vint 0 -> v = value_of e) && emp.
Definition v_R (h : list hist_el) (v : val) := emp.
Definition atomic_entry sh p := !!(field_compatible tentry [] p) && EX lkey : val, EX lval : val,
field_at sh tentry [StructField _lkey] lkey p *
atomic_loc sh lkey (field_address tentry [StructField _key] p) (vint 0) Tsh k_R *
field_at sh tentry [StructField _lvalue] lval p *
atomic_loc sh lval (field_address tentry [StructField _value] p) (vint 0) Tsh v_R.
(* Can we comprehend the per-entry histories into a broader history? *)
Definition failed_CAS k (a b : hist * hist) := exists t r, Forall (fun x => fst x < t)%nat (fst a) /\
fst b = fst a ++ [(t, CAS (Vint r) (vint 0) (vint k))] /\
r <> Int.zero /\ r <> Int.repr k /\ snd b = snd a /\
(let v := value_of_hist (fst a) in v <> vint 0 -> v = Vint r).
Definition wf_hists h l := Forall (fun x => ordered_hist (fst x) /\ ordered_hist (snd x) /\
Forall int_op (map snd (fst x)) /\ Forall int_op (map snd (snd x))) h /\ 0 <= l <= Zlength h /\
Forall (fun x => value_of_hist (fst x) <> vint 0) (sublist 0 l h) /\
Forall (fun x => value_of_hist (fst x) = vint 0) (sublist l (Zlength h) h).
Definition make_int v := match v with Vint i => Int.signed i | _ => 0 end.
Fixpoint make_map h :=
match h with
| [] => []
| (hk, hv) :: rest => let k := make_int (value_of_hist hk) in
if eq_dec k 0 then [] else (k, make_int (value_of_hist hv)) :: make_map rest
end.
Definition set_item_trace (h : list (hist * hist)) k v i h' := 0 <= i < Zlength h /\
Forall2 (failed_CAS k) (sublist 0 i h) (sublist 0 i h') /\
(let '(hk, hv) := Znth i h ([], []) in exists t r tv, Forall (fun x => fst x < t)%nat hk /\
Forall (fun x => fst x < tv)%nat hv /\
Znth i h' ([], []) = (hk ++ [(t, CAS r (vint 0) (vint k))], hv ++ [(tv, Store (vint v))]) /\
(r = vint 0 \/ r = vint k) /\ (let v := value_of_hist hk in v <> vint 0 -> v = r)) /\
sublist (i + 1) (Zlength h) h = sublist (i + 1) (Zlength h') h'.
(* What can a thread know? At least certain keys exist, and whatever it did last took effect. It can even rely on the indices of known keys. *)
Definition set_item_spec :=
DECLARE _set_item
WITH key : Z, value : Z, p : val, sh : share, entries : list val, h : list (hist * hist), l : Z
PRE [ _key OF tint, _value OF tint ]
PROP (repable_signed key; repable_signed value; readable_share sh; key <> 0; Forall isptr entries;
Zlength h = 20; wf_hists h l)
LOCAL (temp _key (vint key); temp _value (vint value); gvar _m_entries p)
SEP (data_at sh (tarray (tptr tentry) 20) entries p;
fold_right_sepcon (map (atomic_entry sh) entries);
entry_hists entries h)
POST [ tvoid ]
EX i : Z, EX h' : list (hist * hist),
PROP (set_item_trace h key value i h')
LOCAL ()
SEP (data_at sh (tarray (tptr tentry) 20) entries p;
fold_right_sepcon (map (atomic_entry sh) entries);
entry_hists entries h').
(* set_item_trace_map describes the properties on the resulting map. *)
Definition failed_load k (a b : hist * hist) := exists t r, Forall (fun x => fst x < t)%nat (fst a) /\
fst b = fst a ++ [(t, Load (Vint r))] /\ r <> Int.zero /\ r <> Int.repr k /\ snd b = snd a /\
(let v := value_of_hist (fst a) in v <> vint 0 -> v = Vint r).
(* get_item can return 0 in two cases: if the key is not in the map, or if its value is 0. In correct use, the latter should only occur if the value has not been initialized. Conceptually, this is still linearizable because we could have just checked before the key was added, but at a finer-grained level we can tell the difference from the history, so we might as well keep this information. *)
Definition get_item_trace (h : list (hist * hist)) k v i h' := 0 <= i < Zlength h /\
Forall2 (failed_load k) (sublist 0 i h) (sublist 0 i h') /\
(let '(hk, hv) := Znth i h ([], []) in exists t r, Forall (fun x => fst x < t)%nat hk /\
fst (Znth i h' ([], [])) = hk ++ [(t, Load (vint r))] /\
(v = 0 /\ r = 0 /\ snd (Znth i h' ([], [])) = hv \/
r = k /\ exists tv, Forall (fun x => fst x < tv)%nat hv /\
snd (Znth i h' ([], [])) = hv ++ [(tv, Load (vint v))]) /\
(let v := value_of_hist hk in v <> vint 0 -> v = vint r)) /\
sublist (i + 1) (Zlength h) h = sublist (i + 1) (Zlength h') h'.
(* Read the most recently written value. *)
Definition get_item_spec :=
DECLARE _get_item
WITH key : Z, p : val, sh : share, entries : list val, h : list (hist * hist), l : Z
PRE [ _key OF tint, _value OF tint ]
PROP (repable_signed key; readable_share sh; key <> 0; Forall isptr entries; Zlength h = 20; wf_hists h l)
LOCAL (temp _key (vint key); gvar _m_entries p)
SEP (data_at sh (tarray (tptr tentry) 20) entries p;
fold_right_sepcon (map (atomic_entry sh) entries);
entry_hists entries h)
POST [ tint ]
EX value : Z, EX i : Z, EX h' : list (hist * hist),
PROP (repable_signed value; get_item_trace h key value i h')
LOCAL (temp ret_temp (vint value))
SEP (data_at sh (tarray (tptr tentry) 20) entries p;
fold_right_sepcon (map (atomic_entry sh) entries);
entry_hists entries h').
Definition Gprog : funspecs := ltac:(with_library prog [surely_malloc_spec; atomic_CAS_spec; atomic_load_spec;
atomic_store_spec; set_item_spec; get_item_spec]).
Opaque upto.
Ltac cancel_for_forward_call ::= repeat (rewrite ?sepcon_andp_prop', ?sepcon_andp_prop);
repeat (apply andp_right; [auto; apply prop_right; auto|]); fast_cancel.
Ltac entailer_for_return ::= go_lower; entailer'.

Lemma apply_int_ops : forall v h i (Hv : verif_atomics.apply_hist (Vint i) h = Some v)
(Hints : Forall int_op h), tc_val tint v.