Set Bullet Behavior "Strict Subproofs".
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.
Definition tnode := Tstruct _node noattr.
(* Each thread's share of the head should act as permission to get the same share of any other node in the list. In fact, it might need to maintain a list of nodes it knows about (for which it owns a share) and retain the right to get a share of any new node it finds. In this model, each time it loads from next it checks whether it's finding a new node or one that it already owns, and gains a share or not accordingly. *)
(* Alternatively, it could just have the right to get *some* readable share of any other node. This will make it impossible to rejoin the shares or know that they're all recollected, but maybe that's fine. We could even try using a token factory. *)
(* A tail element with INT_MAX ensures that we never fall off the end. *)
Definition node_fun gsh1 gsh2 R a := let '(e0, g, p) := a in
EX sh : share, EX e : Z, EX next : val, EX lock : val, !!(readable_share sh /\ repable_signed e /\ e0 < e /\
if eq_dec e Int.max_signed then next = nullval else True) &&
data_at sh tnode (vint e, (next, lock)) p * ghost_var gsh1 p g *
EX g' : val, lock_inv sh lock (EX p : val, ghost_var gsh2 p g') *
if eq_dec e Int.max_signed then emp else atomic_loc sh next (fun v => |>R (e, g', v)).
Definition node gsh1 gsh2 := HORec (node_fun gsh1 gsh2).
Hint Resolve node_isptr : saturate_local.
Definition acquire_spec := DECLARE _acquire acquire_spec.
Definition release_spec := DECLARE _release release_spec.
Definition makelock_spec := DECLARE _makelock (makelock_spec _).
Notation "'WITH'  x1 : t1 , x2 : t2 , x3 : t3 , x4 : t4 , x5 : t5 , x6 : t6 , x7 : t7 , x8 : t8 , x9 : t9 , x10 : t10 , x11 : t11 , x12 : t12 , x13 : t13 , x14 : t14 , x15 : t15 'PRE'  [ u , .. , v ] P 'POST' [ tz ] Q" :=
(NDmk_funspec ((cons u%formals .. (cons v%formals nil) ..), tz) cc_default (t1*t2*t3*t4*t5*t6*t7*t8*t9*t10*t11*t12*t13*t14*t15)
(fun x => match x with (x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15) => P%assert end)
(fun x => match x with (x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15) => 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, x8 at level 0, x9 at level 0,
x10 at level 0, x11 at level 0, x12 at level 0,  x13 at level 0, x14 at level 0,
x15 at level 0,
P at level 100, Q at level 100).
Record node_rep := { data : Z; next : val; lock : val; gnext : val }.
Definition node_data gsh1 gsh2 sh rep p :=
data_at sh tnode (vint (data rep), (next rep, lock rep)) p *
lock_inv sh (lock rep) (EX p : val, ghost_var gsh2 p (gnext rep)) *
if eq_dec (data rep) Int.max_signed then emp
else atomic_loc sh (next rep) (fun v => |>node gsh1 gsh2 (data rep, gnext rep, v)).
Definition node' gsh1 gsh2 rep p := EX sh : share,
!!(readable_share sh /\ repable_signed (data rep) /\
if eq_dec (data rep) Int.max_signed then next rep = nullval else True) &&
node_data gsh1 gsh2 sh rep p.
Definition known_nodes gsh1 gsh2 nodes :=
fold_right sepcon emp (map (fun '(p, rep) => node' gsh1 gsh2 rep p) nodes).
Definition new_node_spec := DECLARE _new_node
WITH e : Z, nnext : val, sh : share, rep : node_rep, gsh1 : share, gsh2 : share
PRE [ _e OF tint, _nnext OF tptr tnode ]
PROP (repable_signed e; readable_share sh; repable_signed (data rep); e < data rep;
sepalg.join gsh1 gsh2 Tsh;
if eq_dec (data rep) Int.max_signed then next rep = nullval else True)
LOCAL (temp _e (vint e); temp _nnext nnext)
SEP (node_data gsh1 gsh2 sh rep nnext)
POST [ tptr tnode ]
EX p : val, EX rep' : node_rep,
PROP (data rep' = e)
LOCAL (temp ret_temp p)
SEP (node_data gsh1 gsh2 Tsh rep' p;
malloc_token Tsh (sizeof tnode) p; malloc_token Tsh (sizeof tlock) (lock rep')).
Definition validate_spec := DECLARE _validate
WITH hp : val, head : val, e : Z, pred : val, curr : val, sh : share, gsh1 : share, gsh2 : share,
reph : node_rep, repp : node_rep, pn : val, repc : node_rep, nodes : _
PRE [ _e OF tint, _pred OF tptr tnode, _curr OF tptr tnode ]
PROP (Int.min_signed < e < Int.max_signed; Int.min_signed <= data repp < e;
readable_share sh; readable_share gsh1; readable_share gsh2; sepalg.join gsh1 gsh2 Tsh;
e <= data repc <= Int.max_signed; data reph = Int.min_signed;
In (head, reph) nodes; In (pred, repp) nodes;
In (curr, repc) nodes; curr <> pred; curr <> head)
LOCAL (gvar _head hp; temp _e (vint e); temp _pred pred; temp _curr curr)
SEP (data_at sh (tptr tnode) head hp; ghost_var gsh2 pn (gnext repp); known_nodes gsh1 gsh2 nodes)
POST [ tint ]
EX b : bool, EX nodes' : _,
PROP (incl nodes nodes'; b = true -> pn = curr)
LOCAL (temp ret_temp (Val.of_bool b))
SEP (data_at sh (tptr tnode) head hp; ghost_var gsh2 pn (gnext repp); known_nodes gsh1 gsh2 nodes';
valid_pointer pn).
Definition tnode_pair := Tstruct _node_pair noattr.
Definition locate_spec := DECLARE _locate
WITH hp : val, head : val, e : Z, sh : share, gsh1 : share, gsh2 : share, reph : node_rep, nodes : _
PRE [ _e OF tint ]
PROP (Int.min_signed < e < Int.max_signed; readable_share sh; readable_share gsh1; readable_share gsh2;
sepalg.join gsh1 gsh2 Tsh; data reph = Int.min_signed; In (head, reph) nodes)
LOCAL (gvar _head hp; temp _e (vint e))
SEP (data_at sh (tptr tnode) head hp; known_nodes gsh1 gsh2 nodes)
POST [ tptr tnode_pair ]
EX r : val, EX pred : val, EX repp : node_rep, EX curr : val, EX repc : node_rep, EX cn : val, EX nodes' : _,
PROP (data repp < e <= data repc; repable_signed (data repp); repable_signed (data repc);
incl nodes nodes'; In (pred, repp) nodes'; In (curr, repc) nodes')
LOCAL (temp ret_temp r)
SEP (data_at Tsh tnode_pair (pred, curr) r; malloc_token Tsh (sizeof tnode_pair) r;
data_at sh (tptr tnode) head hp; known_nodes gsh1 gsh2 nodes';
ghost_var gsh2 curr (gnext repp); ghost_var gsh2 cn (gnext repc)).
(* Could we prove at least simple linearization points after all, e.g. by abstracting the list of nodes into a set and then showing that some atomic step in the function body has the abstract pre and postcondition? This wouldn't be part of a funspec as such, but it's part of RGSep methodology. (See the marked steps in Figure 2 of Proving Correctness of Highly-Concurrent Linearisable Objects, Vafeiadis et al, PPoPP 2006. *)
(* Without such an approach, we don't get much useful information out of the return value, unless we use histories to say that writes occur only on a successful add (which we can, along the lines of hashtable1). *)
Definition add_spec := DECLARE _add
WITH hp : val, head : val, e : Z, sh : share, gsh1 : share, gsh2 : share, reph : node_rep, nodes : _
PRE [ _e OF tint ]
PROP (Int.min_signed < e < Int.max_signed; readable_share sh; readable_share gsh1; readable_share gsh2;
sepalg.join gsh1 gsh2 Tsh; NoDup (map fst nodes); data reph = Int.min_signed; In (head, reph) nodes)
LOCAL (gvar _head hp; temp _e (vint e))
SEP (data_at sh (tptr tnode) head hp; known_nodes gsh1 gsh2 nodes)
POST [ tint ]
EX b : bool, EX rep' : node_rep, EX n' : val, EX nodes' : _,
PROP (data rep' = e; incl nodes nodes'; b = true -> ~In n' (map fst nodes); In (n', rep') nodes')
LOCAL (temp ret_temp (Val.of_bool b))
SEP (data_at sh (tptr tnode) head hp; known_nodes gsh1 gsh2 nodes').
(* A useful spec for remove is even more unclear. How do we know the removed node is no longer in the list? *)
Definition remove_spec := DECLARE _remove
WITH hp : val, head : val, e : Z, sh : share, gsh1 : share, gsh2 : share, reph : node_rep, nodes : _
PRE [ _e OF tint ]
PROP (Int.min_signed < e < Int.max_signed; readable_share sh; readable_share gsh1; readable_share gsh2;
sepalg.join gsh1 gsh2 Tsh; data reph = Int.min_signed; In (head, reph) nodes)
LOCAL (gvar _head hp; temp _e (vint e))
SEP (data_at sh (tptr tnode) head hp; known_nodes gsh1 gsh2 nodes)
POST [ tint ]
EX b : bool, EX n' : val, EX nodes' : _,
PROP (incl nodes nodes'; b = true -> exists rep', In (n', rep') nodes' /\ data rep' = e)
LOCAL (temp ret_temp (Val.of_bool b))
SEP (data_at sh (tptr tnode) head hp; known_nodes gsh1 gsh2 nodes').
Definition Gprog : funspecs := ltac:(with_library prog [surely_malloc_spec; acquire_spec; release_spec;
makelock_spec; make_atomic_spec; load_SC_spec; store_SC_spec;
validate_spec; locate_spec; new_node_spec; add_spec; remove_spec]).
Ltac cancel_for_forward_call ::= repeat (rewrite ?sepcon_andp_prop', ?sepcon_andp_prop);
repeat (apply andp_right; [auto; apply prop_right; auto|]); fast_cancel.
Admitted. (* probably not actually positive *)
Hint Resolve node_lock_inv_positive.
Admitted.
Hint Resolve node_precise.

Lemma body_new_node : semax_body Vprog Gprog f_new_node new_node_spec.