Set Bullet Behavior "Strict Subproofs".
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.
Definition acquire_spec := DECLARE _acquire acquire_spec.
Definition release_spec := DECLARE _release release_spec.
Definition makelock_spec := DECLARE _makelock (makelock_spec _).
Definition freelock_spec := DECLARE _freelock (freelock_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).
(* lock invariant for atomic locations *)
Definition tatomic := Tstruct _atomic_loc noattr.
Definition A_inv p l R := EX v : Z, !!(repable_signed v) &&
(field_at Tsh tatomic [StructField _val] (vint v) p * R v *
(weak_exclusive_mpred (R v) && emp) * malloc_token Tsh tatomic p * malloc_token Tsh tlock l).
Definition atomic_loc sh p R := !!(field_compatible tatomic [] p) &&
(EX lock : val, field_at sh tatomic [StructField _lock] lock p * lock_inv sh lock (A_inv p lock R)).
Definition MA_spec i P (R : Z -> mpred) Q := P -* |==> (R i * (weak_exclusive_mpred (R i) && emp) * Q).
Definition MA_type := ProdType (ProdType (ProdType (ConstType Z) Mpred) (ArrowType (ConstType Z) Mpred)) Mpred.
Program Definition make_atomic_spec := DECLARE _make_atomic TYPE MA_type
WITH i : Z, P : mpred, R : Z -> mpred, Q : mpred
PRE [ _i OF tint ]
PROP (repable_signed i)
LOCAL (temp _i (vint i))
SEP (P; MA_spec i P R Q)
POST [ tptr tatomic ]
EX p : val,
PROP ()
LOCAL (temp ret_temp p)
SEP (atomic_loc Tsh p R; Q).
Next Obligation.
Next Obligation.
Program Definition free_atomic_spec := DECLARE _free_atomic
TYPE ProdType (ConstType val) (ArrowType (ConstType Z) Mpred)
WITH p : val, R : Z -> mpred
PRE [ _tgt OF tptr tatomic ]
PROP ()
LOCAL (temp _tgt p)
SEP (atomic_loc Tsh p R)
POST [ tint ]
EX v : Z,
PROP (repable_signed v)
LOCAL (temp ret_temp (vint v))
SEP (R v).
Next Obligation.
Next Obligation.
Definition AL_spec P (R : Z -> mpred) Q := forall vx, repable_signed vx -> view_shift (R vx * P) (R vx * Q vx).
Definition AL_type := ProdType (ProdType (ProdType (ConstType (share * val))
Mpred) (ArrowType (ConstType Z) Mpred)) (ArrowType (ConstType Z) Mpred).
(* One obvious restriction on this rule that might be needed for soundness (but maybe not for SC?) is that the footprint of P be empty, and vice versa for store. *)
(* For this to work with load_acquire, Q needs to be somehow future-proof: it should be okay even if v wasn't actually the latest value of tgt. For instance, Q might only get a history that's some prefix of the latest state. *)
Program Definition load_SC_spec := DECLARE _load_SC TYPE AL_type
WITH sh : share, tgt : val, P : mpred, R : Z -> mpred, Q : Z -> mpred
PRE [ _tgt OF tptr tatomic ]
PROP (AL_spec P R Q; readable_share sh)
LOCAL (temp _tgt tgt)
SEP (atomic_loc sh tgt R; P)
POST [ tint ]
EX v : Z,
PROP (repable_signed v)
LOCAL (temp ret_temp (vint v))
SEP (atomic_loc sh tgt R; Q v).
Next Obligation.
Next Obligation.
Definition AS_spec v P (R : Z -> mpred) Q := forall vx, repable_signed vx ->
view_shift (R vx * P)
(R v * (weak_precise_mpred (R v) && emp) * Q).
Definition AS_type := ProdType (ProdType (ProdType
(ConstType (share * val * Z)) Mpred) (ArrowType (ConstType Z) Mpred)) Mpred.
Program Definition store_SC_spec := DECLARE _store_SC
TYPE AS_type WITH sh : share, tgt : val, v : Z, P : mpred, R : Z -> mpred, Q : mpred
PRE [ _tgt OF tptr tatomic, _v OF tint ]
PROP (AS_spec v P R Q; readable_share sh; repable_signed v)
LOCAL (temp _tgt tgt; temp _v (vint v))
SEP (atomic_loc sh tgt R; P)
POST [ tvoid ]
PROP ()
LOCAL ()
SEP (atomic_loc sh tgt R; Q).
Next Obligation.
Next Obligation.
Definition ACAS_spec c v P (R Q : Z -> mpred) := forall vx, repable_signed vx ->
view_shift (R vx * P)
(R (if eq_dec c vx then v else vx) * (weak_precise_mpred (R (if eq_dec c vx then v else vx)) && emp) * Q vx).
Definition ACAS_type := ProdType (ProdType (ProdType
(ConstType (share * val * Z * Z)) Mpred)
(ArrowType (ConstType Z) Mpred))
(ArrowType (ConstType Z) Mpred).
Program Definition CAS_SC_spec := DECLARE _CAS_SC
TYPE ACAS_type WITH sh : share, tgt : val, c : Z, v : Z, P : mpred, R : Z -> mpred, Q : Z -> mpred
PRE [ _tgt OF tptr tatomic, _c OF tint, _v OF tint ]
PROP (ACAS_spec c v P R Q; readable_share sh; repable_signed c; repable_signed v)
LOCAL (temp _tgt tgt; temp _c (vint c); temp _v (vint v))
SEP (atomic_loc sh tgt R; P)
POST [ tint ]
EX v' : Z,
PROP (repable_signed v')
LOCAL (temp ret_temp (if eq_dec c v' then vint 1 else vint 0))
SEP (atomic_loc sh tgt R; Q v').
Next Obligation.
Next Obligation.
Definition Gprog : funspecs := ltac:(with_library prog [acquire_spec; release_spec; makelock_spec; freelock_spec;
surely_malloc_spec; make_atomic_spec; free_atomic_spec; load_SC_spec; store_SC_spec; CAS_SC_spec]).
Hint Resolve A_inv_positive.
Hint Resolve atomic_loc_isptr : saturate_local.
(* Now, we can specialize these to the history PCM. *)
Inductive hist_el := Load (v : val) | Store (v : val) | CAS (r : val) (c : val) (w : val).
Instance EqDec_hist_el : EqDec hist_el.
Fixpoint apply_hist a h :=
match h with
| [] => Some a
| Load v :: h' => if eq_dec v a then apply_hist a h' else None
| Store v :: h' => apply_hist v h'
| CAS r c w :: h' => if eq_dec r a then if eq_dec c a then apply_hist w h' else apply_hist a h' else None
end.
Notation hist := (list (nat * hist_el)).
Definition writes e v :=
match e with
| Load _ => False
| Store v' => v' = v
| CAS r c v' => r = c /\ v' = v
end.
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 value_of_hist (h : hist) := value_of (snd (last h (O, Store (vint 0)))).
Notation ordered_hist := (ordered_hist (Store (vint 0))).
Definition full_hist h v := exists l, hist_list h l /\ apply_hist (vint 0) l = Some (vint v).
Definition full_hist' h v := exists l, hist_list' h l /\ apply_hist (vint 0) l = Some v.
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.
Definition make_int v := match v with Vint i => Int.signed i | _ => 0 end.
Definition hist_R g i R v := EX h : _, !!(apply_hist (vint i) h = Some (vint v)) && ghost_ref h g * R h v.
Definition atomic_loc_hist sh p g i R (h : hist) := atomic_loc sh p (hist_R g i R) * ghost_hist sh h g.
Hint Resolve atomic_loc_hist_isptr : saturate_local.
Hint Resolve hist_R_precise.
Notation init_hist := (Some (Tsh, [] : hist), Some ([] : hist)).
(* The user must make the init_hist before calling make_atomic, so that the ghost location is known. *)
Notation MA_witness g i R :=
(i%Z, ghost init_hist g * R%function [] i%Z, hist_R g i R, ghost_hist Tsh ([] : hist) g).
Inductive add_events h : list hist_el -> hist -> Prop :=
| add_events_nil : add_events h [] h
| add_events_snoc : forall le h' t e (Hh' : add_events h le h') (Ht : newer h' t),
add_events h (le ++ [e]) (h' ++ [(t, e)]).
Hint Resolve add_events_nil.
(* FCSL takes the approach that h is always empty, and the previous history is framed out and then combined with the new event by hist join. We can do that, but whether it's preferable might be a matter of taste. *)
Notation AL_witness sh p g i R h P Q :=
(sh%logic, p%logic, (ghost_hist sh h g * P)%logic, hist_R g%logic i R,
EX h' : hist, fun v => !!(add_events h [Load (vint v)] h') && ghost_hist sh h' g * Q v).
Notation AS_witness sh p g i R h v P Q :=
(sh%logic, p%logic, v%Z%logic, (ghost_hist sh h g * P)%logic, hist_R g%logic i R,
EX h' : hist, !!(add_events h [Store (vint v)] h') && ghost_hist sh h' g * Q).
Notation ACAS_witness sh p g i R h c v P Q :=
(sh%logic, p%logic, c%Z%logic, v%Z%logic, (ghost_hist sh h g * P)%logic, hist_R g%logic i R,
fun v' => EX h' : hist, !!(add_events h [CAS (vint v') (vint c) (vint v)] h') &&
ghost_hist sh h' g * Q v').

Lemma atomic_loc_hist_join : forall sh1 sh2 sh p g i R h1 h2 h (Hjoin : sepalg.join sh1 sh2 sh)
(Hh : Permutation.Permutation (h1 ++ h2) h) (Hsh1 : readable_share sh1) (Hsh2 : readable_share sh2),
atomic_loc_hist sh1 p g i R h1 * atomic_loc_hist sh2 p g i R h2 =
!!(disjoint h1 h2) && atomic_loc_hist sh p g i R h.