(* This is some tentative work-in-progress *)
Fixpoint list_nat (n:nat) (x:value) {struct n} :=
match n, x with
| 0, value_label 1%positive => True
| S n', value_cons (value_label 1%positive) x' => list_nat n' x'
| _, _ => False
end.
Fixpoint list_length (x:value) :=
match x with
| value_cons _ x' => S (list_length x')
| _ => 0
end.
Definition list_nat_var (n:nat) (v:var) (r:store) :=
match r#v with
| None => False
| Some x => list_nat n x
end.
Program Definition add_term_measure : termMeas :=
fun r n =>
match r#(V 1) with
| Some x => list_length x = n
| None => False
end.
Next Obligation.
destruct x as [ | x o0 x1] ; [contradiction H | ].
destruct x; [ contradiction H | simpl in *] .
destruct o; simpl in *;  [congruence | contradiction].
Qed.
Definition add_P' n m st :=
list_nat_var n (V 1) st /\
list_nat_var m (V 2) st.
Definition add_Q' n m st := list_nat_var (n+m) (V 2) st.
Definition add_P (nm:nat*nat) := store_op (add_P' (fst nm) (snd nm)).
Definition add_Q (nm:nat*nat) := store_op (add_Q' (fst nm) (snd nm)).
Definition valueTermMeas :=
{ R: value -> nat -> Prop |
forall v n n', R v n -> R v n' -> n = n' }.
Record stdFunspec A :=
{ sfs_t     : valueTermMeas
; sfs_P     : A -> value -> pred prog
; sfs_Q     : A -> value -> pred prog
}.
Implicit Arguments sfs_t.
Implicit Arguments sfs_P.
Implicit Arguments sfs_Q.
Program Definition value_to_store_termMeas (vt:valueTermMeas) : termMeas :=
fun s n => match s#(V 0) with
| Some v => proj1_sig vt v n
| None   => False
end.
Next Obligation.
destruct x; simpl in *; intuition.
destruct o; simpl in *; intuition.
destruct vt; simpl in *.
eauto.
Qed.
(* Define a simple calling convention for "standard" functions.  register 0 is for arguments and results. registers 1 2 3 and 4 are callee-saves registers, and registers >= 5 are caller-saves.  It is not specified, but register 1 is usually used as a value stack. *)
Definition stdfun (l:label) (fs:{A:Type & stdFunspec A}) :=
funptr l (projT1 fs * (value*value*value*value))
(value_to_store_termMeas (sfs_t (projT2 fs)))
(fun avs =>
match avs with
(a,(v1,v2,v3,v4)) =>
EX v0:_,
world_op
(sfs_P (projT2 fs) a v0)
(fun s =>
s#(V 0) = Some v0 /\
s#(V 1) = Some v1 /\
s#(V 2) = Some v2 /\
s#(V 3) = Some v3 /\
s#(V 4) = Some v4)
end)
(fun avs =>
match avs with
(a,(v1,v2,v3,v4)) =>
EX v0:_,
world_op
(sfs_Q (projT2 fs) a v0)
(fun s =>
s#(V 0) = Some v0 /\
s#(V 1) = Some v1 /\
s#(V 2) = Some v2 /\
s#(V 3) = Some v3 /\
s#(V 4) = Some v4)
end).
Definition apply_P (fs:{ A:Type & stdFunspec A}) (x:projT1 fs) (v:value) : pred prog :=
match v with
| value_cons (value_label l) v' =>
stdfun l fs && sfs_P (projT2 fs) x v'
| _ => FF
end.
Definition apply_Q (fs:{A :Type & stdFunspec A}) (x:projT1 fs) (v:value) : pred prog :=
sfs_Q (projT2 fs) x v.
Program Definition apply_tm (fs:{A:Type & stdFunspec A}) : valueTermMeas :=
fun v n =>
match v, n with
| value_cons (value_label l) v', S n' =>
sfs_t (projT2 fs) v' n'
| _, _ => False
end.
Next Obligation.
destruct v; simpl in *; intuition.
discriminate.
destruct v1; simpl in *; intuition; discriminate.
Qed.
Next Obligation.
intros [? ?].
inv H.
Qed.
Next Obligation.
destruct v; simpl in *; try contradiction.
destruct v1; simpl in *; try contradiction.
destruct n; simpl in *; try contradiction.
destruct n'; simpl in *; try contradiction.
destruct fs; simpl in *.
destruct s; simpl in *.
destruct sfs_t0; simpl in *.
f_equal; eapply e; eauto.
Qed.
Definition apply_fs (fs:{A:Type & stdFunspec A}) : {A:Type & stdFunspec A} :=
existT _ (projT1 fs)
(Build_stdFunspec (projT1 fs) (apply_tm fs) (apply_P fs) (apply_Q fs)).
Program Definition phi : map instruction :=
set _ (set _ (set _ (set _ (set _ (set _ (empty _)
(* The "map" wrapper function *)
(L 5)
( (* push the values of V2 and V3 *)
instr_cons (V 2) (V 1) (V 1) ;;
instr_cons (V 3) (V 1) (V 1) ;;
(* load the function pointer into V2 *)
instr_fetch_field (V 0) 0 (V 2) ;;
(* load the remainder of the list into V3 *)
instr_fetch_field (V 0) 1 (V 3) ;;
(* call the map worker function *)
instr_getlabel (L 4) (V 5) ;;
instr_call (V 5) ;;
(* restore V3 *)
instr_fetch_field (V 1) 0 (V 3) ;;
instr_fetch_field (V 1) 1 (V 1) ;;
(* restore V2 *)
instr_fetch_field (V 1) 0 (V 2) ;;
instr_fetch_field (V 1) 1 (V 1) ;;
instr_return
))
(* The "map" worker function *)
(L 4)
( instr_if_nil (V 3)
(*if nil, return nil *)
( instr_getlabel (L 0) (V 0) ;;
instr_return )
(*otherwise, recursive call*)
( (* get the head of the list *)
instr_fetch_field (V 3) 0 (V 0) ;;
(* call the mapping function *)
instr_call (V 2) ;;
(* push the mapped value *)
instr_cons (V 0) (V 1) (V 1) ;;
(* pop the head of the list *)
instr_fetch_field (V 3) 1 (V 3) ;;
(* recursive "map" call *)
instr_getlabel (L 4) (V 5) ;;
instr_call (V 5) ;;
(* add the new list head *)
instr_fetch_field (V 1) 0 (V 5) ;;
instr_cons (V 5) (V 0) (V 0) ;;
(* pop the stack *)
instr_fetch_field (V 1) 1 (V 1) ;;
instr_return
)
(* endif *)
))
(* The "succ" function *)
(L 3)
( instr_getlabel (L 0) (V 5) ;;
instr_cons (V 5) (V 0) (V 0) ;;
instr_return
))
(* Set up a double-indirect call to succ. Call apply, which indirectly calls apply to call succ. *)
(L 2)
( instr_getlabel (L 0) (V 0) ;;
instr_getlabel (L 3) (V 1) ;;
instr_getlabel (L 0) (V 2) ;;
instr_getlabel (L 0) (V 3) ;;
instr_getlabel (L 0) (V 4) ;;
instr_cons (V 2) (V 0) (V 0) ;;
instr_cons (V 2) (V 0) (V 0) ;;
instr_cons (V 1) (V 0) (V 0) ;;
instr_getlabel (L 1) (V 1) ;;
instr_cons (V 1) (V 0) (V 0) ;;
instr_call (V 1) ;;
instr_return
))
(* The "apply" function *)
(L 1)
( instr_fetch_field (V 0) 0 (V 5) ;;
instr_fetch_field (V 0) 1 (V 0) ;;
instr_call (V 5) ;;
instr_return
))
(* An addition function *)
(L 0)
( instr_assert (EX nm:_, add_P nm) ;;
instr_if_nil (V 1)
(*then *) ( instr_return ) (*else *) ( (instr_fetch_field (V 1) 0 (V 3) ;; instr_fetch_field (V 1) 1 (V 1) ;; instr_cons (V 3) (V 2) (V 2)) ;; instr_getlabel (L 0) (V 0) ;; (instr_call (V 0) ;; instr_return) ) ).  Program Definition succ_fs : stdFunspec nat := Build_stdFunspec nat (fun _ n => n = 0) (fun n v => !!(list_nat n v)) (fun n v => !!(list_nat (S n) v)).  Definition succ_fs' : {A:Type & stdFunspec A} := existT (fun X => stdFunspec X) nat succ_fs.  Lemma succ_verify : forall G, verify_prog phi G -> verify_prog phi (stdfun (L 3) succ_fs' && G).  Section map_tm. Variable (f_tm : valueTermMeas).  Fixpoint map_inner_tm (v:value) : nat -> Prop := fun n => match v with | value_label _ => n = 0 | value_cons v1 v2 => exists x1, exists x2, proj1_sig f_tm v1 x1 /\ map_inner_tm v2 x2  /\ n = 1 + x1 + 1 + x2 end.  Lemma map_inner_tm_fun : forall v x1 x2, map_inner_tm v x1 -> map_inner_tm v x2 -> x1 = x2. End map_tm.  Program Definition map_worker_tm (fs:{A:Type & stdFunspec A}) : termMeas := fun s n => match s#(V 3) with | Some v => map_inner_tm (sfs_t (projT2 fs)) v n | _ => False end. Next Obligation. congruence. Qed. Next Obligation. simpl in *. destruct (x#4); simpl in *; intuition. eapply map_inner_tm_fun; eauto. Qed.  Program Definition map_tm (fs:{A:Type & stdFunspec A}) : valueTermMeas := fun v n => match v, n with | value_cons _ v, S n'  => map_inner_tm (sfs_t (projT2 fs)) v n' | _, _ => False end. Next Obligation. intros [? ?]. inv H. Qed. Next Obligation. destruct v. elim H. destruct n; destruct n'; try tauto. f_equal. eapply map_inner_tm_fun; eauto. Qed.  Section map_pre_post. Variable A:Type. Variable P:A->value->pred prog.  Fixpoint list_val_match (l:list A) (v:value) {struct l} : pred prog := match l, v with | nil, value_label 1%positive => TT | x::l', value_cons v1 v2 => P x v1 && list_val_match l' v2 | _, _ => FF end. End map_pre_post.  Definition map_worker_pre (fs:{A:Type & stdFunspec A}) (x:value*label*list (projT1 fs)*value) := match x with (v1,lab,l,v4) => EX v3:_, world_op (stdfun lab fs && list_val_match (projT1 fs) (sfs_P (projT2 fs)) l v3) (fun s => s#(V 1) = Some v1 /\ s#(V 2) = Some (value_label lab) /\ s#(V 3) = Some v3 /\ s#(V 4) = Some v4) end.  Definition map_worker_post (fs:{A:Type & stdFunspec A}) (x:value*label*list (projT1 fs)*value) := match x with (v1,lab,l,v4) => EX v0:_, world_op (stdfun lab fs && list_val_match (projT1 fs) (sfs_Q (projT2 fs)) l v0) (fun s => s#(V 0) = Some v0 /\ s#(V 1) = Some v1 /\ s#(V 2) = Some (value_label lab) /\ s#(V 4) = Some v4) end.  Definition map_pre (fs:{A:Type & stdFunspec A}) l (x:value) := match x with | value_cons (value_label lab) v => stdfun lab fs && list_val_match (projT1 fs) (sfs_P (projT2 fs)) l v | _ => FF end.  Definition map_post (fs:{A:Type & stdFunspec A}) l (x:value) := list_val_match (projT1 fs) (sfs_Q (projT2 fs)) l x.  Definition map_spec (fs:{A:Type & stdFunspec A}) : {A:Type & stdFunspec A} := existT (fun X => stdFunspec X) (list (projT1 fs)) (Build_stdFunspec _ (map_tm fs) (map_pre fs) (map_post fs)).  Lemma map_worker_verify : forall G, verify_prog phi G -> verify_prog phi ((ALL fs:{A:Type & stdFunspec A}, funptr (L 4) _ (map_worker_tm fs) (map_worker_pre fs) (map_worker_post fs)) && G).  Lemma map_verify : forall G, verify_prog phi G -> verify_prog phi ((ALL fs:{A:Type & stdFunspec A}, stdfun (L 5) (map_spec fs)) && ((ALL fs:{A:Type & stdFunspec A}, funptr (L 4) _ (map_worker_tm fs) (map_worker_pre fs) (map_worker_post fs)) && G)).  Lemma apply_verify : forall G, verify_prog phi G -> verify_prog phi ((ALL fs:{A:Type & stdFunspec A}, stdfun (L 1) (apply_fs fs)) && G).  Lemma add_verify : forall G, verify_prog phi G -> verify_prog phi (funptr (L 0) _ add_term_measure add_P add_Q && G).  Program Definition main_tm : termMeas := fun _ n => n = 5.  Let PROG_G := (funptr (L 2) unit main_tm (fun _ => TT) (fun _ => store_op (fun r => exists v, r#(V 0) = Some v /\ list_nat 3 v))) && ((stdfun (L 3) succ_fs') && ((ALL fs:{A:Type & stdFunspec A}, stdfun (L 1) (apply_fs fs)) && ((funptr (L 0) _ add_term_measure add_P add_Q) && TT))).  Lemma main_verify : verify_prog phi PROG_G.  Lemma main_totally_correct : forall r c, phi#(L 2) = Some c -> exists n', exists p', exists r', stepstar (K.squash (n',phi)) p' r ((c ;; instr_assert FF)::nil) r' nil /\ exists v, r'#(V 0) = Some v /\ list_nat 3 v.  (* For every store satisfying the addition precondition, calling the addition function will halt with a store satisfing the postcondition. *)
Transparent list_nat.

(* Specifications: *)
Lemma addition_totally_correct :
forall r n m c,
add_P' n m r ->
phi#(L 0) = Some c ->
exists n', exists p', exists r',
stepstar (K.squash (n',phi)) p'
r ((c ;; instr_assert FF)::nil)
r' nil /\
add_Q' n m r'.