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 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).
(* lock invariant for atomic locations *)
Definition tatomic := Tstruct _atomic_loc noattr.
(* v needs to be valid so we can do comparison on it for CAS. *)
Definition valid R v := (R v && |>valid_pointer v).
Definition A_inv p l R := EX v : val, !!(is_pointer_or_null v) &&
field_at Tsh tatomic [StructField _val] v p * valid R v *
(weak_precise_mpred (R v) && emp) * malloc_token Tsh (sizeof tatomic) p * malloc_token Tsh (sizeof 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)).
Notation "'TYPE' A 'WITH'  x1 : t1 , x2 : t2 , x3 : t3 , x4 : t4 'PRE'  [ u , .. , v ] P 'POST' [ tz ] Q" :=
(mk_funspec ((cons u%formals .. (cons v%formals nil) ..), tz) cc_default A
(fun (ts: list Type) (x: t1*t2*t3*t4) =>
match x with (x1,x2,x3,x4) => P%assert end)
(fun (ts: list Type) (x: t1*t2*t3*t4) =>
match x with (x1,x2,x3,x4) => Q%assert end) _ _)
(at level 200, x1 at level 0, x2 at level 0, x3 at level 0, x4 at level 0,
P at level 100, Q at level 100).
Definition MA_spec v P (R : val -> mpred) Q := view_shift P (valid R v * (weak_precise_mpred (R v) && emp) * Q).
Definition MA_type := ProdType (ProdType (ProdType (ConstType val) Mpred) (ArrowType (ConstType val) Mpred)) Mpred.
Program Definition make_atomic_spec := DECLARE _make_atomic TYPE MA_type
WITH v : val, P : mpred, R : val -> mpred, Q : mpred
PRE [ _v OF tptr tvoid ]
PROP (MA_spec v P R Q)
LOCAL (temp _v v)
SEP (P)
POST [ tptr tatomic ]
EX p : val,
PROP ()
LOCAL (temp ret_temp p)
SEP (atomic_loc Tsh p R; Q).
Next Obligation.
Next Obligation.
Notation "'TYPE' A 'WITH'  x1 : t1 , x2 : t2 'PRE'  [ u , .. , v ] P 'POST' [ tz ] Q" :=
(mk_funspec ((cons u%formals .. (cons v%formals nil) ..), tz) cc_default A
(fun (ts: list Type) (x: t1*t2) =>
match x with (x1,x2) => P%assert end)
(fun (ts: list Type) (x: t1*t2) =>
match x with (x1,x2) => Q%assert end) _ _)
(at level 200, x1 at level 0, x2 at level 0,
P at level 100, Q at level 100).
Program Definition free_atomic_spec := DECLARE _free_atomic
TYPE ProdType (ConstType val) (ArrowType (ConstType val) Mpred)
WITH p : val, R : val -> mpred
PRE [ _tgt OF tptr tatomic ]
PROP ()
LOCAL (temp _tgt p)
SEP (atomic_loc Tsh p R)
POST [ tptr tvoid ]
EX v : val,
PROP ()
LOCAL (temp ret_temp v)
SEP (valid R v).
Next Obligation.
Next Obligation.
Definition AL_spec P (R : val -> mpred) Q := forall vx, view_shift (valid R vx * P) (valid R vx * Q vx).
Definition AL_type := ProdType (ProdType (ProdType (ConstType (share * val))
Mpred) (ArrowType (ConstType val) Mpred)) (ArrowType (ConstType val) Mpred).
Notation "'TYPE' A 'WITH'  x1 : t1 , x2 : t2 , x3 : t3 , x4 : t4 , x5 : t5 'PRE'  [ u , .. , v ] P 'POST' [ tz ] Q" :=
(mk_funspec ((cons u%formals .. (cons v%formals nil) ..), tz) cc_default A
(fun (ts: list Type) (x: t1*t2*t3*t4*t5) =>
match x with (x1,x2,x3,x4,x5) => P%assert end)
(fun (ts: list Type) (x: t1*t2*t3*t4*t5) =>
match x with (x1,x2,x3,x4,x5) => Q%assert end) _ _)
(at level 200, x1 at level 0, x2 at level 0, x3 at level 0, x4 at level 0,
x5 at level 0,
P at level 100, Q at level 100).
(* 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 : val -> mpred, Q : val -> 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 [ tptr tvoid ]
EX v : val,
PROP (is_pointer_or_null v)
LOCAL (temp ret_temp v)
SEP (atomic_loc sh tgt R; Q v).
Next Obligation.
Next Obligation.
Notation "'TYPE' A 'WITH'  x1 : t1 , x2 : t2 , x3 : t3 , x4 : t4 , x5 : t5 , x6 : t6 'PRE'  [ u , .. , v ] P 'POST' [ tz ] Q" :=
(mk_funspec ((cons u%formals .. (cons v%formals nil) ..), tz) cc_default A
(fun (ts: list Type) (x: t1*t2*t3*t4*t5*t6) =>
match x with (x1,x2,x3,x4,x5,x6) => P%assert end)
(fun (ts: list Type) (x: t1*t2*t3*t4*t5*t6) =>
match x with (x1,x2,x3,x4,x5,x6) => Q%assert end) _ _)
(at level 200, x1 at level 0, x2 at level 0, x3 at level 0, x4 at level 0,
x5 at level 0, x6 at level 0,
P at level 100, Q at level 100).
Definition AS_spec v P (R : val -> mpred) Q := forall vx, view_shift (valid R vx * P)
(valid R v * (weak_precise_mpred (R v) && emp) * Q).
Definition AS_type := ProdType (ProdType (ProdType
(ConstType (share * val * val)) Mpred) (ArrowType (ConstType val) Mpred)) Mpred.
Program Definition store_SC_spec := DECLARE _store_SC
TYPE AS_type WITH sh : share, tgt : val, v : val, P : mpred, R : val -> mpred, Q : mpred
PRE [ _tgt OF tptr tatomic, _v OF tptr tvoid ]
PROP (AS_spec v P R Q; readable_share sh)
LOCAL (temp _tgt tgt; temp _v 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 : val -> mpred) := forall vx, view_shift (valid R vx * P)
(valid 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 * val * val)) Mpred)
(ArrowType (ConstType val) Mpred)) (ArrowType (ConstType val) Mpred).
Notation "'TYPE' A 'WITH'  x1 : t1 , x2 : t2 , x3 : t3 , x4 : t4 , x5 : t5 , x6 : t6 , x7 : t7 'PRE'  [ u , .. , v ] P 'POST' [ tz ] Q" :=
(mk_funspec ((cons u%formals .. (cons v%formals nil) ..), tz) cc_default A
(fun (ts: list Type) (x: t1*t2*t3*t4*t5*t6*t7) =>
match x with (x1,x2,x3,x4,x5,x6,x7) => P%assert end)
(fun (ts: list Type) (x: t1*t2*t3*t4*t5*t6*t7) =>
match x with (x1,x2,x3,x4,x5,x6,x7) => Q%assert end) _ _)
(at level 200, x1 at level 0, x2 at level 0, x3 at level 0, x4 at level 0,
x5 at level 0, x6 at level 0, x7 at level 0,
P at level 100, Q at level 100).
Program Definition CAS_SC_spec := DECLARE _CAS_SC
TYPE ACAS_type WITH sh : share, tgt : val, c : val, v : val, P : mpred, R : val -> mpred, Q : val -> mpred
PRE [ _tgt OF tptr tatomic, _c OF tptr tvoid, _v OF tptr tvoid ]
PROP (ACAS_spec c v P R Q; readable_share sh)
LOCAL (temp _tgt tgt; temp _c c; temp _v v)
SEP (atomic_loc sh tgt R; P && valid_pointer c)
POST [ tint ]
EX v' : val,
PROP ()
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 v.
Definition full_hist' h v := exists l, hist_list' h l /\ apply_hist (vint 0) l = Some v.
(* Rather than carry the initial value, let's just write it as the first element in the history. *)
Definition hist_R g R v := EX h : _, !!(apply_hist (vint 0) h = Some v) && ghost_ref h g * valid (R h) v.
Definition atomic_loc_hist sh p g R (h : hist) := atomic_loc sh p (hist_R g R) * ghost_hist sh h g.
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 v R :=
(v, ghost init_hist g * R%function [] v, hist_R g 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.

Lemma add_events_add : forall h le h', add_events h le h' -> exists h2, h' = h ++ h2 /\ map snd h2 = le.