From iris.algebra Require Import frac.
From iris.proofmode Require Import tactics.
From iris.base_logic Require Import invariants.
Require Import Eqdep_dec List.
From cap_machine Require Import cap_lang region contiguous.

Section helpers.

  (* ---------------------------- Helper Lemmas --------------------------------------- *)

  Definition isCorrectPC_range p g b e a0 an :=
    ∀ ai, (a0 <= ai)%a ∧ (ai < an)%a → isCorrectPC (inr (p, g, b, e, ai)).

  Lemma isCorrectPC_inrange p g b (e a0 an a: Addr) :
    isCorrectPC_range p g b e a0 an →
    (a0 <= a < an)%Z →
    isCorrectPC (inr (p, g, b, e, a)).
  Proof.
    unfold isCorrectPC_range. move=> /(_ a) HH ?. apply HH. eauto.
  Qed.

  Lemma isCorrectPC_contiguous_range p g b e a0 an a l :
    isCorrectPC_range p g b e a0 an →
    contiguous_between l a0 an →
    a ∈ l →
    isCorrectPC (inr (p, g, b, e, a)).
  Proof.
    intros Hr Hc Hin.
    eapply isCorrectPC_inrange; eauto.
    eapply contiguous_between_middle_bounds'; eauto.
  Qed.

  Lemma isCorrectPC_range_perm p g b e a0 an :
    isCorrectPC_range p g b e a0 an →
    (a0 < an)%a →
    p = RX ∨ p = RWX ∨ p = RWLX.
  Proof.
    intros Hr H0n.
    assert (isCorrectPC (inr (p, g, b, e, a0))) as HH by (apply Hr; solve_addr).
    inversion HH; auto.
  Qed.

  Lemma isCorrectPC_range_npE p g b e a0 an :
    isCorrectPC_range p g b e a0 an →
    (a0 < an)%a →
    p ≠ E.
  Proof.
    intros HH1 HH2.
    destruct (isCorrectPC_range_perm _ _ _ _ _ _ HH1 HH2) as [?| [?|?] ];
      congruence.
  Qed.

  Lemma isCorrectPC_range_restrict p g b e a0 an a0' an' :
    isCorrectPC_range p g b e a0 an →
    (a0 <= a0')%a ∧ (an' <= an)%a →
    isCorrectPC_range p g b e a0' an'.
  Proof.
    intros HR [? ?] a' [? ?]. apply HR. solve_addr.
  Qed.

  Lemma isCorrectPC_range_monotone p g b e a0 an a' a'':
    isCorrectPC_range p g b e a0 an →
    (a0 <= a')%a → (a'' <= an)%a →
    isCorrectPC_range p g b e a' a''.
  Proof.
    intros. intros a1 [Ha'1 Ha'2]. apply H. solve_addr.
  Qed.

  Lemma isCorrectPC_range_split :
    ∀ (p : Perm) (g : Locality) (b e a0 an a_link : Addr),
      isCorrectPC_range p g b e a0 an
      → (a0 <= a_link)%a → (a_link <= an)%a →
      isCorrectPC_range p g b e a0 a_link ∧ isCorrectPC_range p g b e a_link an.
  Proof.
    intros * HCorr ??. split; eapply isCorrectPC_range_monotone; eauto; solve_addr.
  Qed.

  Lemma pc_range_not_E  pc_p pc_g pc_b pc_e a_first a_last a_tail:
    isCorrectPC_range pc_p pc_g pc_b pc_e a_first a_last →
    contiguous_between (a_first :: a_tail) a_first a_last →
    pc_p ≠ E.
  Proof.
    intros Hvpc Hcont.
    apply isCorrectPC_range_perm in Hvpc as [Heq | [Heq | Heq] ]; subst; auto.
    apply (contiguous_between_middle_bounds _ 0 a_first) in Hcont as [_ Hlt]; auto.
  Qed.

  Lemma pc_range_perm  pc_p pc_g pc_b pc_e a_first a_last a_tail:
    isCorrectPC_range pc_p pc_g pc_b pc_e a_first a_last →
    contiguous_between (a_first :: a_tail) a_first a_last →
    pc_p = RX ∨ pc_p = RWX ∨ pc_p = RWLX.
  Proof.
    intros Hvpc Hcont.
    apply isCorrectPC_range_perm in Hvpc as [Heq | [Heq | Heq] ]; subst; auto.
    apply (contiguous_between_middle_bounds _ 0 a_first) in Hcont as [_ Hlt]; auto.
  Qed.

  Lemma pc_range_nonO  pc_p pc_g pc_b pc_e a_first a_last a_tail:
    isCorrectPC_range pc_p pc_g pc_b pc_e a_first a_last →
    contiguous_between (a_first :: a_tail) a_first a_last →
    pc_p ≠ O.
  Proof.
    intros Hcorr Hcont.
    assert (pc_p = RX ∨ pc_p = RWX ∨ pc_p = RWLX) as [-> | [-> | ->] ] by (eapply pc_range_perm; eauto); auto.
  Qed.

  Lemma pc_range_readA  pc_p pc_g pc_b pc_e a_first a_last a_tail:
    isCorrectPC_range pc_p pc_g pc_b pc_e a_first a_last →
    contiguous_between (a_first :: a_tail) a_first a_last →
    readAllowed pc_p = true.
  Proof.
    intros Hcorr Hcont.
    assert (pc_p = RX ∨ pc_p = RWX ∨ pc_p = RWLX) as [-> | [-> | ->] ] by (eapply pc_range_perm; eauto); auto.
  Qed.

End helpers.

(* -------------------------------- LTACS ------------------------------------------- *)

  (* Destructing -parts of- sequences of addresses *)
  Ltac prep_addr_core list n :=
    match eval compute in n with
    | 0 => idtac
    | _ => destruct list;[done|]; prep_addr_core list (pred n) end.

  Ltac prep_addr_list list Hcont n :=
    let l := fresh "l" in
    destruct list as [| list l];[done|];
    apply contiguous_between_cons_inv_first in Hcont as Heq; subst list;
    prep_addr_core l (pred n).

  Ltac destruct_addr_list list :=
    let l := fresh "l" in
    destruct list as [| list l];[done|];
    repeat (destruct l;[done|]); destruct l; [|done].

  Ltac prep_addr_list_full list Hcont :=
    destruct_addr_list list;
    apply contiguous_between_cons_inv_first in Hcont as Heq; subst list.

  (* Tactics for single instruction spec application *)
  Ltac iPrologue_pre :=
    match goal with
    | Hlen : length ?a = ?n |- _ =>
      let a' := fresh "a" in
      destruct a as [| a' a]; inversion Hlen; simpl
    end.

  Ltac iPrologue prog :=
    let str_destr := constr:(("[Hi " ++ prog ++ "]")%string) in
    iDestruct prog as str_destr;
    iApply (wp_bind (fill [SeqCtx])).

  Ltac iEpilogue prog :=
    iNext; iIntros prog; iSimpl;
    iApply wp_pure_step_later;auto;iNext.

  Ltac iEpilogueLoad z prog :=
    iNext; iIntros (z) prog; iSimpl;
    iApply wp_pure_step_later;auto;iNext.

  Ltac iCorrectPC i j :=
    eapply isCorrectPC_contiguous_range with (a0 := i) (an := j); eauto; [];
    cbn; solve [ repeat constructor ].

  Ltac iContiguous_next Ha index :=
    apply contiguous_of_contiguous_between in Ha;
    generalize (contiguous_spec _ Ha index); auto.

  Lemma lst_lkup_head `{A : Type} hd (tail : list A) :
    (hd :: tail) !! 0 = Some hd.
  Proof. done. Qed.
  Lemma lst_lkup_cons `{A : Type} hd (tail : list A) i:
    (hd :: tail) !! (i + 1) = tail !! i.
  Proof. rewrite -plus_n_Sm Nat.add_0_r. rewrite -lookup_tail. simpl. done. Qed.
  Ltac iContiguous_next_a Ha :=
    apply contiguous_of_contiguous_between in Ha;
    eapply (contiguous_spec _ Ha);
    [repeat first [ by apply lst_lkup_head | erewrite lst_lkup_cons ] | done].
  Ltac iCorrectPC_a :=
    match goal with
    | _ : isCorrectPC_range _ _ _ _ ?i ?j |- _ =>
      eapply isCorrectPC_contiguous_range with (a0 := i) (an := j); eauto; [];
      cbn; solve [ repeat constructor ]
    end.

  Ltac contiguous_between_clean Hcont :=
    repeat apply contiguous_between_weak in Hcont.

  (* Tactics in case of CPS spec *)
  Ltac derive_length Hprog Hprog_len :=
    iDestruct (big_sepL2_length with Hprog) as %Hprog_len; simpl in Hprog_len.
  Ltac split_program Hprog Hcont a_link :=
    let str_destr := constr:(("(Hcode & " ++ Hprog ++ " & #Hcontig)")%string) in
    let l_code := fresh "l_code" in
    let l_rest := fresh "l_rest" in
    iDestruct (contiguous_between_program_split with Hprog) as (l_code l_rest a_link)  str_destr;[apply Hcont|]; clear Hcont.
  Ltac split_PC_range Hvpc Hcont_code Hcont a_linka :=
    let Hvpc_code := fresh "Hvpc_code" in
    let Hvpc_rest := fresh "Hvpc_rest" in
    edestruct isCorrectPC_range_split with (a_link := a_linka) as [Hvpc_code Hvpc_rest];[exact Hvpc| apply (contiguous_between_bounds _ _ _ Hcont_code) | apply (contiguous_between_bounds _ _ _ Hcont)| ..]; clear Hvpc; rename Hvpc_rest into Hvpc.

  Ltac iPrologue_multi Hprog Hcont Hvpc a_link :=
    split_program Hprog Hcont a_link;
    let Hcont_code := fresh "Hcont_code" in
    let Hlink := fresh "Hlink" in
    let Hre := fresh "Hre" in
    iDestruct "Hcontig" as %(Hcont_code & Hcont & Hre & Hlink);
    rewrite -> Hre in *; clear Hre;
    let Hlength_code := fresh "Hlength_code" in
    derive_length "Hcode" Hlength_code;
    rewrite Hlength_code in Hlink; clear Hlength_code;
    let Hlength := fresh "Hlength" in
    derive_length Hprog Hlength;
    split_PC_range Hvpc Hcont_code Hcont a_link.

  Tactic Notation "iEpilogue_multi" constr(Hprog) hyp_list(Hclear) :=
    let Hfresh := fresh "Hfresh" in
    assert (Hfresh : True) by auto;
    iNext; iIntros Hprog; clear Hfresh Hclear.

  Ltac frame_conjunction Hyp :=
    repeat (iDestruct Hyp as "[Hi Hprog_done]"; iFrame "Hi"); iFrame; auto.

  (* Adding and removing pointso from a map *)

 Ltac extract_pointsto_map regs Hmap rname Hrdom Hreg :=
    let rval := fresh "v"rname in
    let Hsome := fresh "Hsome" in
    let str_destr := constr:(("[" ++ Hreg ++ " " ++ Hmap ++ "]")%string) in
    assert (is_Some (regs !! rname)) as [rval Hsome] by (apply Hrdom; repeat constructor);
    iDestruct (big_sepM_delete _ _ rname with Hmap) as str_destr; first by simplify_map_eq.
  Ltac solve_insert_dom :=
  rewrite -(not_elem_of_dom (D := (gset RegName)));
  match goal with
  | [ H : dom (gset RegName) _ = _ |- _ ] =>
    rewrite H end;
  set_solver+.

  Ltac insert_pointsto_map_dom Hmap Hreg:=
    let str_destr := constr:(("[ $" ++ Hmap ++ " $" ++ Hreg ++ "]")%string) in
    iDestruct (big_sepM_insert with str_destr) as Hmap;
    [(repeat rewrite lookup_insert_ne //;[]); solve_insert_dom | ].

  Ltac insert_pointsto_map_del Hmap Hreg :=
    let str_destr := constr:(("[ $" ++ Hmap ++ " $" ++ Hreg ++ "]")%string) in
    iDestruct (big_sepM_insert with str_destr) as Hmap;
    [by simplify_map_eq | repeat (rewrite -delete_insert_ne //;[]); try rewrite insert_delete].

   Ltac insert_pointsto_map Hmap Hreg :=
     first [insert_pointsto_map_del Hmap Hreg | insert_pointsto_map_dom Hmap Hreg].


Require Import VST.floyd.proofauto.
Require Import VST.progs.append.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.
Definition t_struct_list := Tstruct _list noattr.

Fixpoint listrep (sh: share)
            (contents: list val) (x: val) : mpred :=
 match contents with
 | h::hs =>
              EX y:val,
                data_at sh t_struct_list (h,y) x * listrep sh hs y
 | nil => !! (x = nullval) && emp
 end.

Arguments listrep sh contents x : simpl never.

Lemma listrep_local_facts:
  forall sh contents p,
     listrep sh contents p |--
     !! (is_pointer_or_null p /\ (p=nullval <-> contents=nil)).
Proof.
intros.
revert p; induction contents;
  unfold listrep; fold listrep; intros. entailer!. intuition.
Intros y. entailer!.
split; intro. subst p. destruct H; contradiction. inv H2.
Qed.

Hint Resolve listrep_local_facts : saturate_local.

Lemma listrep_valid_pointer:
  forall sh contents p,
   sepalg.nonidentity sh ->
   listrep sh contents p |-- valid_pointer p.
Proof.
 destruct contents; unfold listrep; fold listrep; intros; Intros; subst.
 auto with valid_pointer.
 Intros y.
 apply sepcon_valid_pointer1.
 apply data_at_valid_ptr; auto.
 simpl;  computable.
Qed.

Hint Resolve listrep_valid_pointer : valid_pointer.

Lemma listrep_null: forall sh contents,
    listrep sh contents nullval = !! (contents=nil) && emp.
Proof.
destruct contents; unfold listrep; fold listrep.
autorewrite with norm. auto.
apply pred_ext.
Intros y. entailer. destruct H; contradiction.
Intros.
Qed.

Lemma is_pointer_or_null_not_null:
 forall x, is_pointer_or_null x -> x <> nullval -> isptr x.
Proof.
intros.
 destruct x; try contradiction. hnf in H; subst i. contradiction H0; reflexivity.
 apply I.
Qed.

Definition append_spec :=
 DECLARE _append
  WITH sh : share, x: val, y: val, s1: list val, s2: list val
  PRE [ tptr t_struct_list , tptr t_struct_list]
     PROP(writable_share sh)
     PARAMS (x; y) GLOBALS()
     SEP (listrep sh s1 x; listrep sh s2 y)
  POST [ tptr t_struct_list ]
    EX r: val,
     PROP()
     RETURN (r)
     SEP (listrep sh (s1++s2) r).

Definition Gprog : funspecs :=   ltac:(with_library prog [ append_spec ]).

Module Proof1.

Definition lseg (sh: share) (contents: list val) (x z: val) : mpred :=
  ALL cts2:list val, listrep sh cts2 z -* listrep sh (contents++cts2) x.

Lemma body_append: semax_body Vprog Gprog f_append append_spec.
Proof.
start_function.
forward_if.
*
 subst x. rewrite listrep_null.  Intros.  subst.
 forward.
 Exists y.
 entailer!.
 simpl; auto.
*
 forward.
 destruct s1 as [ | v s1']; unfold listrep at 1; fold listrep.
 Intros.  contradiction.
 Intros u.
 remember (v::s1') as s1.
 forward.
 forward_while
      ( EX a: val, EX s1b: list val, EX t: val, EX u: val,
            PROP ()
            LOCAL (temp _x x; temp _t t; temp _u u; temp _y y)
            SEP (listrep sh (a::s1b++s2) t -* listrep sh (s1++s2) x;
                   data_at sh t_struct_list (a,u) t;
                   listrep sh s1b u;
                   listrep sh s2 y))%assert.
+ (* current assertion implies loop invariant *)
   Exists v s1' x u.
   subst s1. entailer!. simpl. cancel_wand.
+ (* loop test is safe to execute *)
   entailer!.
+ (* loop body preserves invariant *)
   clear v Heqs1.
   destruct s1b; unfold listrep at 3; fold listrep. Intros. contradiction.
   Intros z.
   forward.
   forward.
   Exists (v,s1b,u0,z). unfold fst, snd.
   simpl app.
   entailer!.
   rewrite sepcon_comm.
   apply RAMIF_PLAIN.trans''.
   apply wand_sepcon_adjoint.
   forget (v::s1b++s2) as s3.
   unfold listrep; fold listrep; Exists u0; auto.
+ (* after the loop *)
   clear v s1' Heqs1.
   forward.
   forward.
   rewrite (proj1 H2 (eq_refl _)).
   Exists x.
   simpl app.
   clear.
   entailer!.
   unfold listrep at 3; fold listrep. Intros.
   pull_right (listrep sh (a :: s2) t -* listrep sh (s1 ++ s2) x).
   apply modus_ponens_wand'.
   unfold listrep at 2; fold listrep. Exists y; cancel.
Qed.

End Proof1.

Module Proof2.

Definition lseg (sh: share) (contents: list val) (x z: val) : mpred :=
  ALL cts2:list val, listrep sh cts2 z -* listrep sh (contents++cts2) x.

Lemma body_append: semax_body Vprog Gprog f_append append_spec.
Proof.
start_function.
forward_if.
*
 subst x. rewrite listrep_null. Intros; subst.
 forward.
 Exists y.
 entailer!.
 simpl; auto.
*
 forward.
 destruct s1 as [ | v s1']; unfold listrep; fold listrep. Intros; contradiction.
 Intros u.
 remember (v::s1') as s1.
 forward.
 forward_while
      (EX s1a: list val,  EX a: val, EX s1b: list val, EX t: val, EX u: val,
            PROP (s1 = s1a ++ a :: s1b)
            LOCAL (temp _x x; temp _t t; temp _u u; temp _y y)
            SEP (lseg sh s1a x t;
                   data_at sh t_struct_list (a,u) t;
                   listrep sh s1b u;
                   listrep sh s2 y))%assert.
+ (* current assertion implies loop invariant *)
   Exists (@nil val) v s1' x u.  entailer!.
   unfold lseg. apply allp_right; intro. simpl. cancel_wand.
+ (* loop test is safe to execute *)
   entailer!.
+ (* loop body preserves invariant *)
   clear v Heqs1. subst s1.
   destruct s1b; unfold listrep; fold listrep. Intros; contradiction.
   Intros z.
   forward.
   forward.
   Exists (s1a++[a],v,s1b,u0,z). unfold fst, snd.
   rewrite !app_ass. simpl app.
   entailer!.
   unfold lseg.
   rewrite sepcon_comm.
   clear.
   apply RAMIF_Q.trans'' with (cons a).
   extensionality cts; simpl; rewrite app_ass; reflexivity.
   apply allp_right; intro. apply wand_sepcon_adjoint.
   unfold listrep at 2; fold listrep; Exists u0.  apply derives_refl.
 + (* after the loop *)
   forward. forward.
   Exists x. entailer!.
   destruct H3 as [? _]. specialize (H3 (eq_refl _)). subst s1b.
   unfold listrep at 1.  Intros. autorewrite with norm.  rewrite H0. rewrite app_ass. simpl app.
   unfold lseg.
   rewrite sepcon_assoc.
   eapply derives_trans; [apply allp_sepcon1 | ]. apply allp_left with (a::s2).
   rewrite sepcon_comm.
   eapply derives_trans; [ | apply modus_ponens_wand].
   apply sepcon_derives; [ | apply derives_refl].
   unfold listrep at 2; fold listrep. Exists y; auto.
Qed.

End Proof2.

Module Proof3.  (*************** inductive lseg *******************)

Fixpoint lseg (sh: share)
            (contents: list val) (x z: val) : mpred :=
 match contents with
 | h::hs => !! (x<>z) &&
              EX y:val,
                data_at sh t_struct_list (h,y) x * lseg sh hs y z
 | nil => !! (x = z /\ is_pointer_or_null x) && emp
 end.

Arguments lseg sh contents x z : simpl never.

Lemma lseg_local_facts:
  forall sh contents p q,
     lseg sh contents p q |--
     !! (is_pointer_or_null p /\ is_pointer_or_null q /\ (p=q <-> contents=nil)).
Proof.
intros.
apply derives_trans with (lseg sh contents p q && !! (is_pointer_or_null p /\
        is_pointer_or_null q /\ (p = q <-> contents = []))).
2: entailer!.
revert p; induction contents; intros; simpl; unfold lseg; fold lseg.
entailer!.
intuition.
Intros y. Exists y.
eapply derives_trans.
apply sepcon_derives.
apply derives_refl.
apply IHcontents.
entailer!.
intuition congruence.
Qed.

Hint Resolve lseg_local_facts : saturate_local.

Lemma lseg_valid_pointer:
  forall sh contents p ,
   sepalg.nonidentity sh ->
   lseg sh contents p nullval |-- valid_pointer p.
Proof.
 destruct contents; unfold lseg; fold lseg; intros. entailer!.
 Intros. Intros y.
 auto with valid_pointer.
Qed.

Hint Resolve lseg_valid_pointer : valid_pointer.

Lemma lseg_eq: forall sh contents x,
    lseg sh contents x x = !! (contents=nil /\ is_pointer_or_null x) && emp.
Proof.
intros.
destruct contents; unfold lseg; fold lseg.
f_equal. f_equal. f_equal. apply prop_ext; intuition.
apply pred_ext.
Intros y. contradiction.
Intros.
Qed.

Lemma lseg_null: forall sh contents,
    lseg sh contents nullval nullval = !! (contents=nil) && emp.
Proof.
intros.
 rewrite lseg_eq.
 apply pred_ext.
 entailer!.
 entailer!.
Qed.

Lemma lseg_cons: forall sh (v u x: val) s,
   readable_share sh ->
 data_at sh t_struct_list (v, u) x * lseg sh s u nullval
 |-- lseg sh [v] x u * lseg sh s u nullval.
Proof.
intros.
     unfold lseg at 2. Exists u.
     entailer.
     destruct s; unfold lseg at 1; fold lseg; entailer.
Qed.

Lemma lseg_cons': forall sh (v u x a b: val) ,
   readable_share sh ->
 data_at sh t_struct_list (v, u) x * data_at sh t_struct_list (a,b) u
 |-- lseg sh [v] x u * data_at sh t_struct_list (a,b) u.
Proof.
intros.
     unfold lseg. Exists u.
     entailer.
Qed.

Lemma lseg_app': forall sh s1 s2 (a w x y z: val),
   readable_share sh ->
   lseg sh s1 w x * lseg sh s2 x y * data_at sh t_struct_list (a,z) y |--
   lseg sh (s1++s2) w y * data_at sh t_struct_list (a,z) y.
Proof.
 intros.
 revert w; induction s1; intro; simpl.
 unfold lseg at 1. entailer!.
 unfold lseg at 1 3; fold lseg. Intros j; Exists j.
 entailer.
 sep_apply (IHs1 j).
 cancel.
Qed.

Lemma lseg_app_null: forall sh s1 s2 (w x: val),
   readable_share sh ->
   lseg sh s1 w x * lseg sh s2 x nullval |--
   lseg sh (s1++s2) w nullval.
Proof.
 intros.
 revert w; induction s1; intro; simpl.
 unfold lseg at 1. entailer!.
 unfold lseg at 1 3; fold lseg. Intros j; Exists j.
 entailer.
 sep_apply (IHs1 j).
 cancel.
Qed.

Lemma lseg_app: forall sh s1 s2 a s3 (w x y z: val),
   readable_share sh ->
   lseg sh s1 w x * lseg sh s2 x y * lseg sh (a::s3) y z |--
   lseg sh (s1++s2) w y * lseg sh (a::s3) y z.
Proof.
 intros.
 unfold lseg at 3 5; fold lseg.
 Intros u; Exists u. rewrite prop_true_andp by auto.
 sep_apply (lseg_app' sh s1 s2 a w x y u); auto.
 cancel.
Qed.

Lemma listrep_lseg_null :
 listrep = fun sh s p => lseg sh s p nullval.
Proof.
extensionality sh s p.
revert p.
induction s; intros.
unfold lseg, listrep; apply pred_ext; entailer!.
unfold lseg, listrep; fold lseg; fold listrep.
apply pred_ext; Intros y; Exists y; rewrite IHs; entailer!.
Qed.

Lemma body_append: semax_body Vprog Gprog f_append append_spec.
Proof.
start_function.
revert POSTCONDITION; rewrite listrep_lseg_null; intro.
forward_if.
*
 subst x. rewrite lseg_null. Intros. subst.
 forward.
 Exists y.
 entailer!.
 simpl; auto.
*
 forward.
 destruct s1 as [ | v s1']; unfold lseg at 1; fold lseg.
 Intros. contradiction H.
 Intros u.
 clear - SH.
 remember (v::s1') as s1.
 forward.
 forward_while
      (EX s1a: list val, EX a: val, EX s1b: list val, EX t: val, EX u: val,
            PROP (s1 = s1a ++ a :: s1b)
            LOCAL (temp _x x; temp _t t; temp _u u; temp _y y)
            SEP (lseg sh s1a x t;
                   data_at sh t_struct_list (a,u) t;
                   lseg sh s1b u nullval;
                   lseg sh s2 y nullval))%assert.
 + (* current assertion implies loop invariant *)
     Exists (@nil val) v s1' x u.
     subst s1. rewrite lseg_eq.
     entailer.
(*     sep_apply (lseg_cons sh v u x s1'); auto. *)
 + (* loop test is safe to execute *)
     entailer!.
 + (* loop body preserves invariant *)
    destruct s1b; unfold lseg at 2; fold lseg.
    Intros. contradiction.
    Intros z.
    forward.
    forward.
    Exists (s1a++a::nil, v0, s1b,u0,z). unfold fst, snd.
    simpl app; rewrite app_ass.
    entailer.
    sep_apply (lseg_cons' sh a u0 t v0 z); auto.
    sep_apply (lseg_app' sh s1a [a] v0 x t u0 z); auto.
    cancel.
 + (* after the loop *)
    clear v s1' Heqs1.
    subst. rewrite lseg_eq. Intros. subst.
    forward.
    forward.
    Exists x.
    entailer!.
    sep_apply (lseg_cons sh a y t s2); auto.
    sep_apply (lseg_app_null sh [a] s2 t y); auto.
    rewrite app_ass.
    sep_apply (lseg_app_null sh s1a ([a]++s2) x t); auto.
Qed.

End Proof3.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*          Andrew W. Appel, Princeton University                      *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU Lesser General Public License as        *)
(*  published by the Free Software Foundation, either version 2.1 of   *)
(*  the License, or  (at your option) any later version.               *)
(*  This file is also distributed under the terms of the               *)
(*  INRIA Non-Commercial License Agreement.                            *)
(*                                                                     *)
(* *********************************************************************)

(** Constructions of semi-lattices. *)

Require Import Coqlib.
Require Import Maps.
Require Import FSets.

(* To avoid useless definitions of inductors in extracted code. *)
Local Unset Elimination Schemes.
Local Unset Case Analysis Schemes.

(** * Signatures of semi-lattices *)

(** A semi-lattice is a type [t] equipped with an equivalence relation [eq],
  a boolean equivalence test [beq], a partial order [ge], a smallest element
  [bot], and an upper bound operation [lub].
  Note that we do not demand that [lub] computes the least upper bound. *)

Module Type SEMILATTICE.

  Parameter t: Type.
  Parameter eq: t -> t -> Prop.
  Axiom eq_refl: forall x, eq x x.
  Axiom eq_sym: forall x y, eq x y -> eq y x.
  Axiom eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
  Parameter beq: t -> t -> bool.
  Axiom beq_correct: forall x y, beq x y = true -> eq x y.
  Parameter ge: t -> t -> Prop.
  Axiom ge_refl: forall x y, eq x y -> ge x y.
  Axiom ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
  Parameter bot: t.
  Axiom ge_bot: forall x, ge x bot.
  Parameter lub: t -> t -> t.
  Axiom ge_lub_left: forall x y, ge (lub x y) x.
  Axiom ge_lub_right: forall x y, ge (lub x y) y.

End SEMILATTICE.

(** A semi-lattice ``with top'' is similar, but also has a greatest
  element [top]. *)

Module Type SEMILATTICE_WITH_TOP.

  Include SEMILATTICE.
  Parameter top: t.
  Axiom ge_top: forall x, ge top x.

End SEMILATTICE_WITH_TOP.

(** * Semi-lattice over maps *)

Set Implicit Arguments.

(** Given a semi-lattice (without top) [L], the following functor implements
  a semi-lattice structure over finite maps from positive numbers to [L.t].
  The default value for these maps is [L.bot].  Bottom elements are not smashed. *)

Module LPMap1(L: SEMILATTICE) <: SEMILATTICE.

Definition t := PTree.t L.t.

Definition get (p: positive) (x: t) : L.t :=
  match x!p with None => L.bot | Some x => x end.

Definition set (p: positive) (v: L.t) (x: t) : t :=
  if L.beq v L.bot
  then PTree.remove p x
  else PTree.set p v x.

Lemma gsspec:
  forall p v x q,
  L.eq (get q (set p v x)) (if peq q p then v else get q x).
Proof.
  intros. unfold set, get.
  destruct (L.beq v L.bot) eqn:EBOT.
  rewrite PTree.grspec. unfold PTree.elt_eq. destruct (peq q p).
  apply L.eq_sym. apply L.beq_correct; auto.
  apply L.eq_refl.
  rewrite PTree.gsspec. destruct (peq q p); apply L.eq_refl.
Qed.

Definition eq (x y: t) : Prop :=
  forall p, L.eq (get p x) (get p y).

Lemma eq_refl: forall x, eq x x.
Proof.
  unfold eq; intros. apply L.eq_refl.
Qed.

Lemma eq_sym: forall x y, eq x y -> eq y x.
Proof.
  unfold eq; intros. apply L.eq_sym; auto.
Qed.

Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
Proof.
  unfold eq; intros. eapply L.eq_trans; eauto.
Qed.

Definition beq (x y: t) : bool := PTree.beq L.beq x y.

Lemma beq_correct: forall x y, beq x y = true -> eq x y.
Proof.
  unfold beq; intros; red; intros. unfold get.
  rewrite PTree.beq_correct in H. specialize (H p).
  destruct (x!p); destruct (y!p); intuition.
  apply L.beq_correct; auto.
  apply L.eq_refl.
Qed.

Definition ge (x y: t) : Prop :=
  forall p, L.ge (get p x) (get p y).

Lemma ge_refl: forall x y, eq x y -> ge x y.
Proof.
  unfold ge, eq; intros. apply L.ge_refl. auto.
Qed.

Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
Proof.
  unfold ge; intros. apply L.ge_trans with (get p y); auto.
Qed.

Definition bot : t := PTree.empty _.

Lemma get_bot: forall p, get p bot = L.bot.
Proof.
  intros; reflexivity.
Qed.

Lemma ge_bot: forall x, ge x bot.
Proof.
  unfold ge; intros. rewrite get_bot. apply L.ge_bot.
Qed.

(** Equivalence modulo L.eq *)

Definition opt_eq (ox oy: option L.t) : Prop :=
  match ox, oy with
  | None, None => True
  | Some x, Some y => L.eq x y
  | _, _ => False
  end.

Lemma opt_eq_refl: forall ox, opt_eq ox ox.
Proof.
  intros. unfold opt_eq. destruct ox. apply L.eq_refl. auto.
Qed.

Lemma opt_eq_sym: forall ox oy, opt_eq ox oy -> opt_eq oy ox.
Proof.
  unfold opt_eq. destruct ox; destruct oy; auto. apply L.eq_sym.
Qed.

Lemma opt_eq_trans: forall ox oy oz, opt_eq ox oy -> opt_eq oy oz -> opt_eq ox oz.
Proof.
  unfold opt_eq. destruct ox; destruct oy; destruct oz; intuition.
  eapply L.eq_trans; eauto.
Qed.

Definition opt_beq (ox oy: option L.t) : bool :=
  match ox, oy with
  | None, None => true
  | Some x, Some y => L.beq x y
  | _, _ => false
  end.

Lemma opt_beq_correct:
  forall ox oy, opt_beq ox oy = true -> opt_eq ox oy.
Proof.
  unfold opt_beq, opt_eq. destruct ox; destruct oy; try congruence.
  intros. apply L.beq_correct; auto.
  auto.
Qed.

Local Hint Resolve opt_beq_correct opt_eq_refl opt_eq_sym : combine.

(** A [combine] operation over the type [PTree.t L.t] that attempts
  to share its result with its arguments. *)

Section COMBINE.

Variable f: option L.t -> option L.t -> option L.t.
Hypothesis f_none_none: f None None = None.

Inductive changed : Type :=
  | Same
  | Same1
  | Same2
  | Changed (m: PTree.t L.t).

Let Node_combine_l (l1: PTree.t L.t) (lres: changed) (o1: option L.t)
                   (r1: PTree.t L.t) (rres: changed) : changed :=
  let o' := f o1 None in
  match lres, rres with
  | Same1, Same1 =>
      if opt_beq o' o1 then Same1 else Changed (PTree.Node l1 o' r1)
  | Same1, Changed r' => Changed (PTree.Node l1 o' r')
  | Changed l', Same1 => Changed (PTree.Node l' o' r1)
  | Changed l', Changed r' => Changed (PTree.Node l' o' r')
  | _, _ => Same (**r impossible cases *)
  end.

Let xcombine_l (m: PTree.t L.t) : changed :=
  PTree.tree_rec Same1 Node_combine_l m.

Let Node_combine_r (l1: PTree.t L.t) (lres: changed) (o1: option L.t)
                   (r1: PTree.t L.t) (rres: changed) : changed :=
  let o' := f None o1 in
  match lres, rres with
  | Same2, Same2 =>
      if opt_beq o' o1 then Same2 else Changed (PTree.Node l1 o' r1)
  | Same2, Changed r' => Changed (PTree.Node l1 o' r')
  | Changed l', Same2 => Changed (PTree.Node l' o' r1)
  | Changed l', Changed r' => Changed (PTree.Node l' o' r')
  | _, _ => Same (**r impossible cases *)
  end.

Let xcombine_r (m: PTree.t L.t) : changed :=
  PTree.tree_rec Same2 Node_combine_r m.

Let Node_combine_2
             (l1: PTree.t L.t) (o1: option L.t) (r1: PTree.t L.t)
             (l2: PTree.t L.t) (o2: option L.t) (r2: PTree.t L.t)
             (lres: changed) (rres: changed) : changed :=
  let o := f o1 o2 in
  match lres, rres with
  | Same, Same =>
      match opt_beq o o1, opt_beq o o2 with
      | true, true => Same
      | true, false => Same1
      | false, true => Same2
      | false, false => Changed (PTree.Node l1 o r1)
      end
  | Same, Same1
  | Same1, Same
  | Same1, Same1 =>
      if opt_beq o o1 then Same1 else Changed (PTree.Node l1 o r1)
  | Same, Same2
  | Same2, Same
  | Same2, Same2 =>
      if opt_beq o o2 then Same2 else Changed (PTree.Node l2 o r2)
  | Same, Changed m2 => Changed (PTree.Node l1 o m2)
  | Same1, Same2 => Changed (PTree.Node l1 o r2)
  | Same1, Changed m2 => Changed (PTree.Node l1 o m2)
  | Same2, Same1 => Changed (PTree.Node l2 o r1)
  | Same2, Changed m2 => Changed (PTree.Node l2 o m2)
  | Changed m1, (Same|Same1) => Changed (PTree.Node m1 o r1)
  | Changed m1, Same2 => Changed (PTree.Node m1 o r2)
  | Changed m1, Changed m2 => Changed (PTree.Node m1 o m2)
  end.

Definition xcombine :=
  PTree.tree_rec2
    Same
    xcombine_r
    xcombine_l
    Node_combine_2.

Definition tree_agree (m1 m2 m: PTree.t L.t) : Prop :=
  forall i, opt_eq m!i (f m1!i m2!i).

Lemma tree_agree_node: forall l1 o1 r1 l2 o2 r2 l o r,
  tree_agree l1 l2 l -> tree_agree r1 r2 r -> opt_eq (f o1 o2) o ->
  tree_agree (PTree.Node l1 o1 r1) (PTree.Node l2 o2 r2) (PTree.Node l o r).
Proof.
  intros; red; intros. rewrite ! PTree.gNode. destruct i; auto using opt_eq_sym.
Qed.

Local Hint Resolve tree_agree_node : combine.

Lemma gxcombine_l: forall m,
  match xcombine_l m with
  | Same1 => forall i, opt_eq m!i (f m!i None)
  | Changed m' => forall i, opt_eq m'!i (f m!i None)
  | _ => False
  end.
Proof.
  unfold xcombine_l. induction m using PTree.tree_ind.
- simpl; intros. rewrite PTree.gempty, f_none_none. auto.
- rewrite PTree.unroll_tree_rec by auto.
  destruct (PTree.tree_rec Same1 Node_combine_l l);
  destruct (PTree.tree_rec Same1 Node_combine_l r);
  try contradiction;
  unfold Node_combine_l;
  try (intros i; rewrite ! PTree.gNode; destruct i; auto with combine).
  destruct (opt_beq (f o None) o) eqn:BEQ; intros i; rewrite ! PTree.gNode; destruct i; auto with combine.
Qed.

Lemma gxcombine_r: forall m,
  match xcombine_r m with
  | Same2 => forall i, opt_eq m!i (f None m!i)
  | Changed m' => forall i, opt_eq m'!i (f None m!i)
  | _ => False
  end.
Proof.
  unfold xcombine_r. induction m using PTree.tree_ind.
- simpl; intros. rewrite PTree.gempty, f_none_none. auto.
- rewrite PTree.unroll_tree_rec by auto.
  destruct (PTree.tree_rec Same2 Node_combine_r l);
  destruct (PTree.tree_rec Same2 Node_combine_r r);
  try contradiction;
  unfold Node_combine_r;
  try (intros i; rewrite ! PTree.gNode; destruct i; auto with combine).
  destruct (opt_beq (f None o) o) eqn:BEQ; intros i; rewrite ! PTree.gNode; destruct i; auto with combine.
Qed.

Inductive xcombine_spec (m1 m2: PTree.t L.t) : changed -> Prop :=
  | XCS_Same:
      tree_agree m1 m2 m1 -> tree_agree m1 m2 m2 -> xcombine_spec m1 m2 Same
  | XCS_Same1:
      tree_agree m1 m2 m1 -> xcombine_spec m1 m2 Same1
  | XCS_Same2:
      tree_agree m1 m2 m2 -> xcombine_spec m1 m2 Same2
  | XCS_Changed: forall m',
      tree_agree m1 m2 m' -> xcombine_spec m1 m2 (Changed m').

Local Hint Constructors xcombine_spec : combine.

Lemma gxcombine: forall m1 m2, xcombine_spec m1 m2 (xcombine m1 m2).
Proof.
  Local Opaque opt_eq.
  unfold xcombine.
  induction m1 using PTree.tree_ind; induction m2 using PTree.tree_ind; intros.
- constructor; red; intros; rewrite ! PTree.gEmpty, f_none_none; auto with combine.
- rewrite PTree.unroll_tree_rec2_EN by auto. set (m2 := PTree.Node l o r).
  generalize (gxcombine_r m2); destruct (xcombine_r m2);
  try contradiction; constructor; auto.
- rewrite PTree.unroll_tree_rec2_NE by auto. set (m1 := PTree.Node l o r).
  generalize (gxcombine_l m1); destruct (xcombine_l m1);
  try contradiction; constructor; auto.
- rewrite PTree.unroll_tree_rec2_NN by auto.
  clear IHm2 IHm3. specialize (IHm1 l0). specialize (IHm0 r0).
  inv IHm1; inv IHm0; unfold Node_combine_2; auto with combine;
  destruct (opt_beq (f o o0) o) eqn:E1; destruct (opt_beq (f o o0) o0) eqn:E2;
  auto with combine.
Qed.

Definition combine (m1 m2: PTree.t L.t) : PTree.t L.t :=
  match xcombine m1 m2 with
  | Same|Same1 => m1
  | Same2 => m2
  | Changed m => m
  end.

Theorem gcombine:
  forall m1 m2 i, opt_eq (PTree.get i (combine m1 m2)) (f (PTree.get i m1) (PTree.get i m2)).
Proof.
  intros. unfold combine.
  generalize (gxcombine m1 m2); intros XS; inv XS; auto.
Qed.

End COMBINE.

Definition lub (x y: t) : t :=
  combine
    (fun a b =>
       match a, b with
       | Some u, Some v => Some (L.lub u v)
       | None, _ => b
       | _, None => a
       end)
    x y.

Lemma gcombine_bot:
  forall f t1 t2 p,
  f None None = None ->
  L.eq (get p (combine f t1 t2))
       (match f t1!p t2!p with Some x => x | None => L.bot end).
Proof.
  intros. unfold get. generalize (gcombine f H t1 t2 p). unfold opt_eq.
  destruct ((combine f t1 t2)!p); destruct (f t1!p t2!p).
  auto. contradiction. contradiction. intros; apply L.eq_refl.
Qed.

Lemma ge_lub_left:
  forall x y, ge (lub x y) x.
Proof.
  unfold ge, lub; intros.
  eapply L.ge_trans. apply L.ge_refl. apply gcombine_bot; auto.
  unfold get. destruct x!p. destruct y!p.
  apply L.ge_lub_left.
  apply L.ge_refl. apply L.eq_refl.
  apply L.ge_bot.
Qed.

Lemma ge_lub_right:
  forall x y, ge (lub x y) y.
Proof.
  unfold ge, lub; intros.
  eapply L.ge_trans. apply L.ge_refl. apply gcombine_bot; auto.
  unfold get. destruct y!p. destruct x!p.
  apply L.ge_lub_right.
  apply L.ge_refl. apply L.eq_refl.
  apply L.ge_bot.
Qed.

End LPMap1.

(** Given a semi-lattice with top [L], the following functor implements
  a semi-lattice-with-top structure over finite maps from positive numbers to [L.t].
  The default value for these maps is [L.top].  Bottom elements are smashed. *)

Module LPMap(L: SEMILATTICE_WITH_TOP) <: SEMILATTICE_WITH_TOP.

Inductive t' : Type :=
  | Bot: t'
  | Top_except: PTree.t L.t -> t'.

Definition t: Type := t'.

Definition get (p: positive) (x: t) : L.t :=
  match x with
  | Bot => L.bot
  | Top_except m => match m!p with None => L.top | Some x => x end
  end.

Definition set (p: positive) (v: L.t) (x: t) : t :=
  match x with
  | Bot => Bot
  | Top_except m =>
      if L.beq v L.bot
      then Bot
      else Top_except (if L.beq v L.top then PTree.remove p m else PTree.set p v m)
  end.

Lemma gsspec:
  forall p v x q,
  x <> Bot -> ~L.eq v L.bot ->
  L.eq (get q (set p v x)) (if peq q p then v else get q x).
Proof.
  intros. unfold set. destruct x. congruence.
  destruct (L.beq v L.bot) eqn:EBOT.
  elim H0. apply L.beq_correct; auto.
  destruct (L.beq v L.top) eqn:ETOP; simpl.
  rewrite PTree.grspec. unfold PTree.elt_eq. destruct (peq q p).
  apply L.eq_sym. apply L.beq_correct; auto.
  apply L.eq_refl.
  rewrite PTree.gsspec. destruct (peq q p); apply L.eq_refl.
Qed.

Definition eq (x y: t) : Prop :=
  forall p, L.eq (get p x) (get p y).

Lemma eq_refl: forall x, eq x x.
Proof.
  unfold eq; intros. apply L.eq_refl.
Qed.

Lemma eq_sym: forall x y, eq x y -> eq y x.
Proof.
  unfold eq; intros. apply L.eq_sym; auto.
Qed.

Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
Proof.
  unfold eq; intros. eapply L.eq_trans; eauto.
Qed.

Definition beq (x y: t) : bool :=
  match x, y with
  | Bot, Bot => true
  | Top_except m, Top_except n => PTree.beq L.beq m n
  | _, _ => false
  end.

Lemma beq_correct: forall x y, beq x y = true -> eq x y.
Proof.
  destruct x; destruct y; simpl; intro; try congruence.
  apply eq_refl.
  red; intro; simpl.
  rewrite PTree.beq_correct in H. generalize (H p).
  destruct (t0!p); destruct (t1!p); intuition.
  apply L.beq_correct; auto.
  apply L.eq_refl.
Qed.

Definition ge (x y: t) : Prop :=
  forall p, L.ge (get p x) (get p y).

Lemma ge_refl: forall x y, eq x y -> ge x y.
Proof.
  unfold ge, eq; intros. apply L.ge_refl. auto.
Qed.

Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
Proof.
  unfold ge; intros. apply L.ge_trans with (get p y); auto.
Qed.

Definition bot := Bot.

Lemma get_bot: forall p, get p bot = L.bot.
Proof.
  unfold bot; intros; simpl. auto.
Qed.

Lemma ge_bot: forall x, ge x bot.
Proof.
  unfold ge; intros. rewrite get_bot. apply L.ge_bot.
Qed.

Definition top := Top_except (PTree.empty L.t).

Lemma get_top: forall p, get p top = L.top.
Proof.
  unfold top; intros; auto.
Qed.

Lemma ge_top: forall x, ge top x.
Proof.
  unfold ge; intros. rewrite get_top. apply L.ge_top.
Qed.

Module LM := LPMap1(L).

Definition opt_lub (x y: L.t) : option L.t :=
  let z := L.lub x y in
  if L.beq z L.top then None else Some z.

Definition lub (x y: t) : t :=
  match x, y with
  | Bot, _ => y
  | _, Bot => x
  | Top_except m, Top_except n =>
      Top_except
        (LM.combine
           (fun a b =>
              match a, b with
              | Some u, Some v => opt_lub u v
              | _, _ => None
              end)
           m n)
  end.

Lemma gcombine_top:
  forall f t1 t2 p,
  f None None = None ->
  L.eq (get p (Top_except (LM.combine f t1 t2)))
       (match f t1!p t2!p with Some x => x | None => L.top end).
Proof.
  intros. simpl. generalize (LM.gcombine f H t1 t2 p). unfold LM.opt_eq.
  destruct ((LM.combine f t1 t2)!p); destruct (f t1!p t2!p).
  auto. contradiction. contradiction. intros; apply L.eq_refl.
Qed.

Lemma ge_lub_left:
  forall x y, ge (lub x y) x.
Proof.
  unfold ge, lub; intros. destruct x; destruct y.
  rewrite get_bot. apply L.ge_bot.
  rewrite get_bot. apply L.ge_bot.
  apply L.ge_refl. apply L.eq_refl.
  eapply L.ge_trans. apply L.ge_refl. apply gcombine_top; auto.
  unfold get. destruct t0!p. destruct t1!p.
  unfold opt_lub. destruct (L.beq (L.lub t2 t3) L.top) eqn:E.
  apply L.ge_top. apply L.ge_lub_left.
  apply L.ge_top.
  apply L.ge_top.
Qed.

Lemma ge_lub_right:
  forall x y, ge (lub x y) y.
Proof.
  unfold ge, lub; intros. destruct x; destruct y.
  rewrite get_bot. apply L.ge_bot.
  apply L.ge_refl. apply L.eq_refl.
  rewrite get_bot. apply L.ge_bot.
  eapply L.ge_trans. apply L.ge_refl. apply gcombine_top; auto.
  unfold get. destruct t0!p; destruct t1!p.
  unfold opt_lub. destruct (L.beq (L.lub t2 t3) L.top) eqn:E.
  apply L.ge_top. apply L.ge_lub_right.
  apply L.ge_top.
  apply L.ge_top.
  apply L.ge_top.
Qed.

End LPMap.

(** * Semi-lattice over a set. *)

(** Given a set [S: FSetInterface.S], the following functor
    implements a semi-lattice over these sets, ordered by inclusion. *)

Module LFSet (S: FSetInterface.WS) <: SEMILATTICE.

  Definition t := S.t.

  Definition eq (x y: t) := S.Equal x y.
  Definition eq_refl: forall x, eq x x := S.eq_refl.
  Definition eq_sym: forall x y, eq x y -> eq y x := S.eq_sym.
  Definition eq_trans: forall x y z, eq x y -> eq y z -> eq x z := S.eq_trans.
  Definition beq: t -> t -> bool := S.equal.
  Definition beq_correct: forall x y, beq x y = true -> eq x y := S.equal_2.

  Definition ge (x y: t) := S.Subset y x.
  Lemma ge_refl: forall x y, eq x y -> ge x y.
  Proof.
    unfold eq, ge, S.Equal, S.Subset; intros. firstorder.
  Qed.
  Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
  Proof.
    unfold ge, S.Subset; intros. eauto.
  Qed.

  Definition  bot: t := S.empty.
  Lemma ge_bot: forall x, ge x bot.
  Proof.
    unfold ge, bot, S.Subset; intros. elim (S.empty_1 H).
  Qed.

  Definition lub: t -> t -> t := S.union.

  Lemma ge_lub_left: forall x y, ge (lub x y) x.
  Proof.
    unfold lub, ge, S.Subset; intros. apply S.union_2; auto.
  Qed.

  Lemma ge_lub_right: forall x y, ge (lub x y) y.
  Proof.
    unfold lub, ge, S.Subset; intros. apply S.union_3; auto.
  Qed.

End LFSet.

(** * Flat semi-lattice *)

(** Given a type with decidable equality [X], the following functor
  returns a semi-lattice structure over [X.t] complemented with
  a top and a bottom element.  The ordering is the flat ordering
  [Bot < Inj x < Top]. *)

Module LFlat(X: EQUALITY_TYPE) <: SEMILATTICE_WITH_TOP.

Inductive t' : Type :=
  | Bot: t'
  | Inj: X.t -> t'
  | Top: t'.

Definition t : Type := t'.

Definition eq (x y: t) := (x = y).
Definition eq_refl: forall x, eq x x := (@eq_refl t).
Definition eq_sym: forall x y, eq x y -> eq y x := (@eq_sym t).
Definition eq_trans: forall x y z, eq x y -> eq y z -> eq x z := (@eq_trans t).

Definition beq (x y: t) : bool :=
  match x, y with
  | Bot, Bot => true
  | Inj u, Inj v => if X.eq u v then true else false
  | Top, Top => true
  | _, _ => false
  end.

Lemma beq_correct: forall x y, beq x y = true -> eq x y.
Proof.
  unfold eq; destruct x; destruct y; simpl; try congruence; intro.
  destruct (X.eq t0 t1); congruence.
Qed.

Definition ge (x y: t) : Prop :=
  match x, y with
  | Top, _ => True
  | _, Bot => True
  | Inj a, Inj b => a = b
  | _, _ => False
  end.

Lemma ge_refl: forall x y, eq x y -> ge x y.
Proof.
  unfold eq, ge; intros; subst y; destruct x; auto.
Qed.

Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
Proof.
  unfold ge; destruct x; destruct y; try destruct z; intuition.
  transitivity t1; auto.
Qed.

Definition bot: t := Bot.

Lemma ge_bot: forall x, ge x bot.
Proof.
  destruct x; simpl; auto.
Qed.

Definition top: t := Top.

Lemma ge_top: forall x, ge top x.
Proof.
  destruct x; simpl; auto.
Qed.

Definition lub (x y: t) : t :=
  match x, y with
  | Bot, _ => y
  | _, Bot => x
  | Top, _ => Top
  | _, Top => Top
  | Inj a, Inj b => if X.eq a b then Inj a else Top
  end.

Lemma ge_lub_left: forall x y, ge (lub x y) x.
Proof.
  destruct x; destruct y; simpl; auto.
  case (X.eq t0 t1); simpl; auto.
Qed.

Lemma ge_lub_right: forall x y, ge (lub x y) y.
Proof.
  destruct x; destruct y; simpl; auto.
  case (X.eq t0 t1); simpl; auto.
Qed.

End LFlat.

(** * Boolean semi-lattice *)

(** This semi-lattice has only two elements, [bot] and [top], trivially
  ordered. *)

Module LBoolean <: SEMILATTICE_WITH_TOP.

Definition t := bool.

Definition eq (x y: t) := (x = y).
Definition eq_refl: forall x, eq x x := (@eq_refl t).
Definition eq_sym: forall x y, eq x y -> eq y x := (@eq_sym t).
Definition eq_trans: forall x y z, eq x y -> eq y z -> eq x z := (@eq_trans t).

Definition beq : t -> t -> bool := eqb.

Lemma beq_correct: forall x y, beq x y = true -> eq x y.
Proof eqb_prop.

Definition ge (x y: t) : Prop := x = y \/ x = true.

Lemma ge_refl: forall x y, eq x y -> ge x y.
Proof. unfold ge; tauto. Qed.

Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
Proof. unfold ge; intuition congruence. Qed.

Definition bot := false.

Lemma ge_bot: forall x, ge x bot.
Proof. destruct x; compute; tauto. Qed.

Definition top := true.

Lemma ge_top: forall x, ge top x.
Proof. unfold ge, top; tauto. Qed.

Definition lub (x y: t) := x || y.

Lemma ge_lub_left: forall x y, ge (lub x y) x.
Proof. destruct x; destruct y; compute; tauto. Qed.

Lemma ge_lub_right: forall x y, ge (lub x y) y.
Proof. destruct x; destruct y; compute; tauto. Qed.

End LBoolean.

(** * Option semi-lattice *)

(** This lattice adds a top element (represented by [None]) to a given
  semi-lattice (whose elements are injected via [Some]). *)

Module LOption(L: SEMILATTICE) <: SEMILATTICE_WITH_TOP.

Definition t: Type := option L.t.

Definition eq (x y: t) : Prop :=
  match x, y with
  | None, None => True
  | Some x1, Some y1 => L.eq x1 y1
  | _, _ => False
  end.

Lemma eq_refl: forall x, eq x x.
Proof.
  unfold eq; intros; destruct x. apply L.eq_refl. auto.
Qed.

Lemma eq_sym: forall x y, eq x y -> eq y x.
Proof.
  unfold eq; intros; destruct x; destruct y; auto. apply L.eq_sym; auto.
Qed.

Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
Proof.
  unfold eq; intros; destruct x; destruct y; destruct z; auto.
  eapply L.eq_trans; eauto.
  contradiction.
Qed.

Definition beq (x y: t) : bool :=
  match x, y with
  | None, None => true
  | Some x1, Some y1 => L.beq x1 y1
  | _, _ => false
  end.

Lemma beq_correct: forall x y, beq x y = true -> eq x y.
Proof.
  unfold beq, eq; intros; destruct x; destruct y.
  apply L.beq_correct; auto.
  discriminate. discriminate. auto.
Qed.

Definition ge (x y: t) : Prop :=
  match x, y with
  | None, _ => True
  | _, None => False
  | Some x1, Some y1 => L.ge x1 y1
  end.

Lemma ge_refl: forall x y, eq x y -> ge x y.
Proof.
  unfold eq, ge; intros; destruct x; destruct y.
  apply L.ge_refl; auto.
  auto. elim H. auto.
Qed.

Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
Proof.
  unfold ge; intros; destruct x; destruct y; destruct z; auto.
  eapply L.ge_trans; eauto. contradiction.
Qed.

Definition bot : t := Some L.bot.

Lemma ge_bot: forall x, ge x bot.
Proof.
  unfold ge, bot; intros. destruct x; auto. apply L.ge_bot.
Qed.

Definition lub (x y: t) : t :=
  match x, y with
  | None, _ => None
  | _, None => None
  | Some x1, Some y1 => Some (L.lub x1 y1)
  end.

Lemma ge_lub_left: forall x y, ge (lub x y) x.
Proof.
  unfold ge, lub; intros; destruct x; destruct y; auto. apply L.ge_lub_left.
Qed.

Lemma ge_lub_right: forall x y, ge (lub x y) y.
Proof.
  unfold ge, lub; intros; destruct x; destruct y; auto. apply L.ge_lub_right.
Qed.

Definition top : t := None.

Lemma ge_top: forall x, ge top x.
Proof.
  unfold ge, top; intros. auto.
Qed.

End LOption.


Require Import Coq.Lists.List.
Require Import Coq.Numbers.BinNums.
Require Import Crypto.Reflection.Syntax.
Require Import Crypto.Reflection.Named.PositiveContext.
Require Import Crypto.Reflection.CountLets.
Require Import Crypto.Reflection.Named.NameUtil.
Require Import Crypto.Reflection.Named.PositiveContext.Defaults.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.NatUtil.
Require Import Crypto.Util.Tactics.DestructHead.

Section language.
  Context {base_type_code : Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}.

  Lemma name_list_unique_map_pos_of_succ_nat_seq a b
    : name_list_unique (map BinPos.Pos.of_succ_nat (seq a b)).
  Proof.
    unfold name_list_unique, oname_list_unique, mname_list_unique.
    intros k n.
    rewrite !map_map, firstn_map, skipn_map, firstn_seq, skipn_seq.
    rewrite !in_map_iff; intros; destruct_head' ex; destruct_head' and; inversion_option; subst.
    match goal with H : _ |- _ => apply Pnat.SuccNat2Pos.inj in H end; subst.
    rewrite in_seq in *.
    omega *.
  Qed.

  Lemma name_list_unique_default_names_forf {var dummy t e}
    : name_list_unique (@default_names_forf base_type_code op var dummy t e).
  Proof. apply name_list_unique_map_pos_of_succ_nat_seq. Qed.
  Lemma name_list_unique_default_names_for {var dummy t e}
    : name_list_unique (@default_names_for base_type_code op var dummy t e).
  Proof. apply name_list_unique_map_pos_of_succ_nat_seq. Qed.
  Lemma name_list_unique_DefaultNamesFor {t e}
    : name_list_unique (@DefaultNamesFor base_type_code op t e).
  Proof. apply name_list_unique_map_pos_of_succ_nat_seq. Qed.
End language.


From iris.program_logic Require Export weakestpre hoare.
From iris.heap_lang Require Export lang.
From iris.algebra Require Import excl agree csum.
From iris.heap_lang Require Import notation par proofmode.
From iris.proofmode Require Import tactics.
From iris_examples.barrier Require Import proof specification.
Set Default Proof Using "Type".

Definition one_shotR (Σ : gFunctors) (F : oFunctor) :=
  csumR (exclR unitO) (agreeR $ laterO $ F (iPrePropO Σ) _).
Definition Pending {Σ F} : one_shotR Σ F := Cinl (Excl ()).
Definition Shot {Σ} {F : oFunctor} (x : F (iPropO Σ) _) : one_shotR Σ F :=
  Cinr $ to_agree $ Next $ oFunctor_map F (iProp_fold, iProp_unfold) x.

Class oneShotG (Σ : gFunctors) (F : oFunctor) :=
  one_shot_inG :> inG Σ (one_shotR Σ F).
Definition oneShotΣ (F : oFunctor) : gFunctors :=
  #[ GFunctor (csumRF (exclRF unitO) (agreeRF (▶ F))) ].
Instance subG_oneShotΣ {Σ F} : subG (oneShotΣ F) Σ → oneShotG Σ F.
Proof. solve_inG. Qed.

Definition client : val :=
  λ: "fM" "fW1" "fW2",
  let: "b" := newbarrier #() in
  ("fM" #() ;; signal "b") ||| ((wait "b" ;; "fW1" #()) ||| (wait "b" ;; "fW2" #())).

Section proof.
Local Set Default Proof Using "Type*".
Context `{!heapG Σ, !barrierG Σ, !spawnG Σ, !oneShotG Σ F}.
Context (N : namespace).
Local Notation X := (F (iPropO Σ) _).

Definition barrier_res γ (Φ : X → iProp Σ) : iProp Σ :=
  (∃ x, own γ (Shot x) ∗ Φ x)%I.

Lemma worker_spec e γ l (Φ Ψ : X → iProp Σ) :
  recv N l (barrier_res γ Φ) -∗ (∀ x, {{ Φ x }} e {{ _, Ψ x }}) -∗
  WP wait #l ;; e {{ _, barrier_res γ Ψ }}.
Proof.
  iIntros "Hl #He". wp_apply (wait_spec with "[- $Hl]"); simpl.
  iDestruct 1 as (x) "[#Hγ Hx]".
  wp_seq. iApply (wp_wand with "[Hx]"); [by iApply "He"|].
  iIntros (v) "?"; iExists x; by iSplit.
Qed.

Context (P : iProp Σ) (Φ Φ1 Φ2 Ψ Ψ1 Ψ2 : X -n> iPropO Σ).
Context {Φ_split : ∀ x, Φ x -∗ (Φ1 x ∗ Φ2 x)}.
Context {Ψ_join  : ∀ x, Ψ1 x -∗ Ψ2 x -∗ Ψ x}.

Lemma P_res_split γ : barrier_res γ Φ -∗ barrier_res γ Φ1 ∗ barrier_res γ Φ2.
Proof.
  iDestruct 1 as (x) "[#Hγ Hx]".
  iDestruct (Φ_split with "Hx") as "[H1 H2]". by iSplitL "H1"; iExists x; iSplit.
Qed.

Lemma Q_res_join γ : barrier_res γ Ψ1 -∗ barrier_res γ Ψ2 -∗ ▷ barrier_res γ Ψ.
Proof.
  iDestruct 1 as (x) "[#Hγ Hx]"; iDestruct 1 as (x') "[#Hγ' Hx']".
  iAssert (▷ (x ≡ x'))%I as "Hxx".
  { iCombine "Hγ" "Hγ'" as "Hγ2". iClear "Hγ Hγ'".
    rewrite own_valid csum_validI /= agree_validI agree_equivI bi.later_equivI /=.
    rewrite -{2}[x]oFunctor_id -{2}[x']oFunctor_id.
    assert (HF : oFunctor_map F (cid, cid) ≡ oFunctor_map F (iProp_fold (Σ:=Σ) ◎ iProp_unfold, iProp_fold (Σ:=Σ) ◎ iProp_unfold)).
    { apply ne_proper; first by apply _.
      by split; intro; simpl; symmetry; apply iProp_fold_unfold. }
    rewrite (HF x). rewrite (HF x').
    rewrite !oFunctor_compose. iNext. by iRewrite "Hγ2". }
  iNext. iRewrite -"Hxx" in "Hx'".
  iExists x; iFrame "Hγ". iApply (Ψ_join with "Hx Hx'").
Qed.

Lemma client_spec_new (fM fW1 fW2 : val) :
  P -∗
  {{ P }} fM #() {{ _, ∃ x, Φ x }} -∗
  (∀ x, {{ Φ1 x }} fW1 #() {{ _, Ψ1 x }}) -∗
  (∀ x, {{ Φ2 x }} fW2 #() {{ _, Ψ2 x }}) -∗
  WP client fM fW1 fW2 {{ _, ∃ γ, barrier_res γ Ψ }}.
Proof using All.
  iIntros "/= HP #Hf #Hf1 #Hf2"; rewrite /client.
  iMod (own_alloc (Pending : one_shotR Σ F)) as (γ) "Hγ"; first done.
  wp_lam. wp_apply (newbarrier_spec N (barrier_res γ Φ)); auto.
  iIntros (l) "[Hr Hs]".
  set (workers_post (v : val) := (barrier_res γ Ψ1 ∗ barrier_res γ Ψ2)%I).
  wp_apply (par_spec  (λ _, True)%I workers_post with "[HP Hs Hγ] [Hr]").
  - wp_lam. wp_bind (fM #()). iApply (wp_wand with "[HP]"); [by iApply "Hf"|].
    iIntros (v) "HP"; iDestruct "HP" as (x) "HP". wp_seq.
    iMod (own_update with "Hγ") as "Hx".
    { by apply (cmra_update_exclusive (Shot x)). }
    iApply (signal_spec with "[- $Hs]"); last auto.
    iExists x; auto.
  - iDestruct (recv_weaken with "[] Hr") as "Hr"; first by iApply P_res_split.
    iMod (recv_split with "Hr") as "[H1 H2]"; first done.
    wp_apply (par_spec (λ _, barrier_res γ Ψ1)%I
                       (λ _, barrier_res γ Ψ2)%I with "[H1] [H2]").
    + wp_apply (worker_spec with "H1"); auto.
    + wp_apply (worker_spec with "H2"); auto.
    + auto.
  - iIntros (_ v) "[_ [H1 H2]]". iDestruct (Q_res_join with "H1 H2") as "?". auto.
Qed.
End proof.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Import Category.Theory.Category.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

(* This is the category with two objects and two parallel arrows between them
   (and two identity morphisms):

       --- f --->
     x            y
       --- g --->

  This is used to build diagrams that identify equalizers. *)

Inductive ParObj : Type := ParX | ParY.

Inductive ParHom : bool -> ParObj -> ParObj -> Type :=
  | ParIdX : ParHom true ParX ParX
  | ParIdY : ParHom true ParY ParY
  | ParOne : ParHom true ParX ParY
  | ParTwo : ParHom false ParX ParY.

Definition ParHom_inv_t : forall b x y, ParHom b x y -> Prop.
Proof.
  intros [] [] [] f.
  exact (f = ParIdX).
  exact (f = ParOne).
  exact False.          (* Unused, any Prop is ok here *)
  exact (f = ParIdY).
  exact False.          (* Unused, any Prop is ok here *)
  exact (f = ParTwo).
  exact False.          (* Unused, any Prop is ok here *)
  exact False.          (* Unused, any Prop is ok here *)
Defined.

Corollary ParHom_inv b x y f : ParHom_inv_t b x y f.
Proof. destruct f; reflexivity. Qed.

Lemma ParHom_Id_false_absurd : ∀ x, ParHom false x x -> False.
Proof. inversion 1. Qed.

Local Hint Extern 4 =>
  match goal with
    [ H : ParHom false ?X ?X |- _ ] =>
    contradiction (ParHom_Id_false_absurd X H)
  end : parallel_laws.

Lemma ParHom_Y_X_absurd : ∀ b, ParHom b ParY ParX -> False.
Proof. inversion 1. Qed.

Local Hint Extern 4 =>
  match goal with
    [ H : ParHom ?B ParY ParX |- _ ] =>
    contradiction (ParHom_Y_X_absurd B H)
  end : parallel_laws.

Local Ltac reduce :=
  repeat match goal with
  | [ H : ParObj |- _ ] => destruct H
  | [ H : bool   |- _ ] => destruct H
  end; auto.

Set Transparent Obligations.

Program Definition Parallel : Category := {|
  obj     := ParObj;
  hom     := fun x y => ∃ b : bool, ParHom b x y;
  (* Any hom that typechecks is valid. *)
  homset  := fun x y =>
    {| equiv := fun (f g : ∃ b : bool, ParHom b x y) => ``f = ``g |};
  id      := fun x => match x with
    | ParX => (true; ParIdX)
    | ParY => (true; ParIdY)
    end;
  compose := fun x y z (f : ∃ b : bool, ParHom b y z)
                       (g : ∃ b : bool, ParHom b x y) =>
    match x, y, z with
    | ParX, ParX, ParX => (true; ParIdX)
    | ParY, ParY, ParY => (true; ParIdY)
    | ParX, ParY, ParY => _
    | ParX, ParX, ParY => _
    | _,    _,    _    => _
    end
|}.
Next Obligation. equivalence; reduce. Qed.
Next Obligation. exact (f; X0). Defined.
Next Obligation. reduce; intuition. Qed.
Next Obligation. intuition; discriminate. Qed.
Next Obligation. intuition; discriminate. Qed.
Next Obligation. intuition; discriminate. Qed.
Next Obligation.
  proper.
  destruct x, y, z; simpl in *; intuition.
Defined.
Next Obligation.
  destruct x, y; simpl in *;
  destruct f; intuition.
Qed.
Next Obligation.
  destruct x, y; simpl in *;
  destruct f; intuition.
Qed.
Next Obligation.
  destruct x, y, z, w; simpl in *;
  destruct f; intuition.
Qed.
Next Obligation.
  destruct x, y, z, w; simpl in *;
  destruct f; intuition.
Qed.

Require Import Category.Theory.Functor.

Program Definition APair {C : Category} {x y : C} (f g : x ~> y) :
  Parallel ⟶ C := {|
  fobj := fun z => match z with
    | ParX => x
    | ParY => y
    end;
  fmap := fun z w h => match z, w with
    | ParX, ParX => id[x]
    | ParY, ParY => id[y]
    | ParX, ParY =>
      match ``h with
      | true  => f
      | false => g
      end
    | ParY, ParX => False_rect _ (ParHom_Y_X_absurd _ (projT2 h))
    end
|}.
Next Obligation. proper; reduce; simpl; intuition. Qed.
Next Obligation. destruct x0; simpl; cat. Qed.
Next Obligation.
  destruct x0, y0, z; simpl; auto with parallel_laws; cat.
Qed.


Definition default_foldable {f:Type -> Type}
  (foldMap : forall m a, forall (S : GHC.Base.Semigroup m) (M : GHC.Base.Monoid m), (a -> m) -> f a -> m)
  (foldr : forall a b, (a -> b -> b) -> b -> f a -> b):=
  let foldl : forall b a, (b -> a -> b) -> b -> f a -> b :=
      (fun b a =>
         fun f  z t => Data.SemigroupInternal.appEndo
                    (Data.SemigroupInternal.getDual
                       (foldMap _ _ _ _ (Coq.Program.Basics.compose
                                   Data.SemigroupInternal.Mk_Dual
                                   (Coq.Program.Basics.compose
                                      Data.SemigroupInternal.Mk_Endo
                                      (GHC.Base.flip f))) t)) z)
  in
  let foldl' : forall b a, (b -> a -> b) -> b -> f a -> b :=
      (fun {b} {a} =>
         fun f  z0  xs =>
           let f' :=  fun  x  k  z => GHC.Base.op_zdzn__ k (f z x)
           in foldr _ _ f' GHC.Base.id xs z0)
  in
  Foldable__Dict_Build
    f
    (* fold *)
    (fun m (S : GHC.Base.Semigroup m) (M : GHC.Base.Monoid m) => foldMap _ _ _ _ GHC.Base.id)
    (* foldMap *)
    (@foldMap)
    (* foldl *)
    (@foldl)
    (* foldl' *)
    (@foldl')
    (* foldr  *)
    (@foldr)
    (* foldr' *)
    (fun a b f z0 xs =>
       let f' := fun k  x  z => GHC.Base.op_zdzn__ k (f x z)
       in
       @foldl _ _ f' GHC.Base.id xs z0)
    (* length *)
    (fun a => @foldl' _ a (fun c  _ => GHC.Num.op_zp__ c (GHC.Num.fromInteger 1))
                    (GHC.Num.fromInteger 0))
    (* null *)
    (fun a => @foldr _ _ (fun arg_61__ arg_62__ => false) true)
    (* product *)
    (fun a `{GHC.Num.Num a} =>
       Coq.Program.Basics.compose Data.SemigroupInternal.getProduct
                                  (foldMap _ _ _ _ Data.SemigroupInternal.Mk_Product))
    (* sum *)
    (fun a `{GHC.Num.Num a} =>
       Coq.Program.Basics.compose Data.SemigroupInternal.getSum
                                  (foldMap _ _ _ _ Data.SemigroupInternal.Mk_Sum))
    (* toList *)
    (fun a => fun t => GHC.Base.build (fun _ c n => @foldr _ _ c n t)).

Definition default_foldable_foldMap {f : Type -> Type}
  (foldMap : forall {m} {a}, forall `{GHC.Base.Monoid m}, (a -> m) -> f a -> m)
 :=
  let foldr : forall {a} {b}, (a -> b -> b) -> b -> f a -> b :=
  fun a b f z t =>
    Data.SemigroupInternal.appEndo
      (foldMap
         (Coq.Program.Basics.compose Data.SemigroupInternal.Mk_Endo f) t) z
  in
  default_foldable (fun {m}{a} `{GHC.Base.Monoid m} => foldMap) foldr.

Definition default_foldable_foldr (f : Type -> Type)
  (foldr : forall {a} {b}, (a -> b -> b) -> b -> f a -> b) :=
  let foldMap :  forall {m} {a} `{GHC.Base.Monoid m}, (a -> m) -> f a -> m :=
  fun m a (S : GHC.Base.Semigroup m) (H : GHC.Base.Monoid m) =>
    fun f => foldr
            (Coq.Program.Basics.compose GHC.Base.mappend
                                        f) GHC.Base.mempty
  in
  default_foldable foldMap (fun {a} {b} => foldr).


(* Do not edit this file, it was generated automatically *)
Require Import VST.floyd.proofauto.
Require Import VST.floyd.library.
Require Import VST.progs64.object.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Local Open Scope Z.
Local Open Scope logic.

Definition object_invariant := list Z -> val -> mpred.

Definition tobject := tptr (Tstruct _object noattr).

Definition reset_spec (instance: object_invariant) :=
  WITH self: val, history: list Z
  PRE [ tobject]
          PROP ()
          PARAMS (self)
          SEP (instance history self)
  POST [ tvoid ]
          PROP() RETURN () SEP(instance nil self).

Definition twiddle_spec (instance: object_invariant) :=
  WITH self: val, i: Z, history: list Z
  PRE [ tobject, tint]
          PROP (0 < i <= Int.max_signed / 4;
                0 <= fold_right Z.add 0 history <= Int.max_signed / 4)
          PARAMS (self; Vint (Int.repr i))
          SEP (instance history self)
  POST [ tint ]
      EX v: Z,
          PROP(2* fold_right Z.add 0 history < v <= 2* fold_right Z.add 0 (i::history))
          RETURN (Vint (Int.repr v))
          SEP(instance (i::history) self).

Definition object_methods (instance: object_invariant) (mtable: val) : mpred :=
  EX sh: share, EX reset: val, EX twiddle: val,
  !! readable_share sh &&
  func_ptr' (reset_spec instance) reset *
  func_ptr' (twiddle_spec instance) twiddle *
  data_at sh (Tstruct _methods noattr) (reset,twiddle) mtable.

Lemma object_methods_local_facts: forall instance p,
  object_methods instance p |-- !! isptr p.
Proof.
intros.
unfold object_methods.
Intros sh reset twiddle.
entailer!.
Qed.
#[export] Hint Resolve object_methods_local_facts : saturate_local.

Definition object_mpred (history: list Z) (self: val) : mpred :=
  EX instance: object_invariant, EX mtable: val,
       (object_methods instance mtable *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable self*
     instance history self).

Definition foo_invariant : object_invariant :=
  (fun (history: list Z) p =>
    withspacer Ews (sizeof size_t + sizeof tint) (2 * sizeof size_t) (field_at Ews (Tstruct _foo_object noattr)
            [StructField _data] (Vint (Int.repr (2*fold_right Z.add 0 history)))) p
      *  malloc_token Ews (Tstruct _foo_object noattr) p).

Definition foo_reset_spec :=
 DECLARE _foo_reset (reset_spec foo_invariant).

Definition foo_twiddle_spec :=
 DECLARE _foo_twiddle  (twiddle_spec foo_invariant).

Definition make_foo_spec :=
 DECLARE _make_foo
 WITH gv: globals
 PRE [ ]
    PROP () PARAMS() GLOBALS (gv)
    SEP (mem_mgr gv; object_methods foo_invariant (gv _foo_methods))
 POST [ tobject ]
    EX p: val, PROP () RETURN (p)
     SEP (mem_mgr gv; object_mpred nil p; object_methods foo_invariant (gv _foo_methods)).

Definition main_spec :=
 DECLARE _main
  WITH gv: globals
  PRE  [] main_pre prog tt gv
  POST [ tint ]
     EX i:Z, PROP(0<=i<=6) RETURN (Vint (Int.repr i)) SEP(TT).

Definition Gprog : funspecs :=   ltac:(with_library prog [
    foo_reset_spec; foo_twiddle_spec; make_foo_spec; main_spec]).

Lemma object_mpred_i:
  forall (history: list Z) (self: val) (instance: object_invariant) (mtable: val),
    object_methods instance mtable *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable self *
     instance history self
    |-- object_mpred history self.
Proof.
intros. unfold object_mpred. Exists instance mtable; auto.
Qed.

Lemma body_foo_reset: semax_body Vprog Gprog f_foo_reset foo_reset_spec.
Proof.
unfold foo_reset_spec, foo_invariant, reset_spec.
start_function.
unfold withspacer; simpl; Intros.
forward.  (* self->data=0; *)
entailer!.
all: unfold withspacer; simpl; entailer!.  (* needed if Archi.ptr64=true *)
Qed.

Lemma body_foo_twiddle: semax_body Vprog Gprog f_foo_twiddle foo_twiddle_spec.
Proof.
unfold foo_twiddle_spec, foo_invariant, twiddle_spec.
start_function.
unfold withspacer; simpl.
Intros.
forward.  (* d = self->data; *)
forward.  (* self -> data = d+2*i; *)
 set (j:= Int.max_signed / 4) in *; compute in j; subst j.
 forget (fold_right Z.add 0 history) as h.
 entailer!.
forward.  (* return d+i; *)
simpl.
 set (j:= Int.max_signed / 4) in *; compute in j; subst j.
 forget (fold_right Z.add 0 history) as h.
 entailer!.
Exists (2 * fold_right Z.add 0 history + i).
simpl;
entailer!.
rewrite Z.mul_add_distr_l, Z.add_comm.
unfold withspacer; simpl.
entailer!.
Qed.

Lemma split_object_methods:
  forall instance m,
    object_methods instance m |-- object_methods instance m * object_methods instance m.
Proof.
intros.
unfold object_methods.
Intros sh reset twiddle.

Exists (fst (slice.cleave sh)) reset twiddle.
Exists (snd (slice.cleave sh)) reset twiddle.
rewrite (split_func_ptr' (reset_spec instance) reset) at 1.
rewrite (split_func_ptr' (twiddle_spec instance) twiddle) at 1.
entailer!.
split.
apply slice.cleave_readable1; auto.
apply slice.cleave_readable2; auto.
rewrite (data_at_share_join (fst (slice.cleave sh)) (snd (slice.cleave sh)) sh).
auto.
apply slice.cleave_join.
Qed.

Lemma body_make_foo: semax_body Vprog Gprog f_make_foo make_foo_spec.
Proof.
unfold make_foo_spec.
start_function.
forward_call (Tstruct _foo_object noattr, gv).
Intros p.
forward_if
  (PROP ( )
   LOCAL (temp _p p; gvars gv)
   SEP (mem_mgr gv;
          malloc_token Ews (Tstruct _foo_object noattr) p;
          data_at_ Ews (Tstruct _foo_object noattr) p;
          object_methods foo_invariant (gv _foo_methods))).
*
change (Memory.EqDec_val p nullval) with (eq_dec p nullval).
if_tac; entailer!.
*
forward_call 1.
contradiction.
*
rewrite if_false by auto.
Intros.
forward.  (*  /*skip*/;  *)
entailer!.
*
unfold data_at_, field_at_, default_val; simpl.
forward. (* p->mtable = &foo_methods; *)
forward. (* p->data = 0; *)
forward. (* return (struct object * ) p; *)
Exists p.
unfold object_mpred.
Exists foo_invariant (gv _foo_methods).
sep_apply (split_object_methods foo_invariant (gv _foo_methods)).
unfold foo_invariant at 4.
entailer!.
simpl.
unfold_data_at (field_at _ _ nil _ p).
cancel.
unfold withspacer; simpl.
rewrite !field_at_data_at.
simpl.
apply derives_refl'.
rewrite <- ?sepcon_assoc. (* needed if Archi.ptr64=true *)
rewrite !field_compatible_field_address; auto with field_compatible.
clear - H.
(* TODO: simplify the following proof. *)
destruct p; try contradiction.
destruct H as [AL SZ].
repeat split; auto.
simpl in *.  unfold sizeof in *; simpl in *; lia.
eapply align_compatible_rec_Tstruct; [reflexivity |].
simpl co_members; intros.
simpl in H.
if_tac in H; [| inv H].
inv H. inv H0.
eapply align_compatible_rec_by_value.
reflexivity.
rewrite Z.add_0_r.
simpl.
unfold natural_alignment in AL.
eapply Z.divide_trans; [ | apply AL].
apply prove_Zdivide.
reflexivity.
left; auto.
Qed.

Lemma make_object_methods:
  forall sh instance reset twiddle mtable,
  readable_share sh ->
  func_ptr' (reset_spec instance) reset *
  func_ptr' (twiddle_spec instance) twiddle *
  data_at sh (Tstruct _methods noattr) (reset, twiddle) mtable
  |-- object_methods instance mtable.
Proof.
  intros.
  unfold object_methods.
  Exists sh reset twiddle.
  entailer!.
Qed.

Ltac method_call witness hist' result :=
repeat apply seq_assoc1;
match goal with
   |- semax _ (PROPx _ (LOCALx ?Q (SEPx ?R)))
            (Ssequence (Sset ?mt (Efield (Ederef (Etempvar ?x _)  _) _ _))
                 _) _  =>
    match Q with context [temp ?x ?x'] =>
     match R with context [object_mpred _ x'] =>
          let instance := fresh "instance" in let mtable := fresh "mtable" in
          unfold object_mpred; Intros instance mtable;
          forward;
          unfold object_methods at 1;
          let sh := fresh "sh" in let r := fresh "r" in let t := fresh "t" in
          Intros sh r t;
          forward;
          forward_call witness;
          [ .. | try Intros result;
                  sep_apply (make_object_methods sh instance r t mtable); [ auto .. | ];
                  sep_apply (object_mpred_i hist' x' instance mtable);
                  deadvars; try clear dependent sh; try clear r; try clear t
           ]
    end end
end.

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
sep_apply (create_mem_mgr gv).
(* assert_gvar _foo_methods. (* TODO: this is needed for a field_compatible later on *) *)
fold noattr cc_default.
(* 0. This part should be handled automatically by start_function *)
gather_SEP (mapsto _ _ _ _) (data_at _ _ _ _);
replace_SEP 0 (data_at Ews (Tstruct _methods noattr)
   (gv _foo_reset, gv _foo_twiddle) (gv _foo_methods)). {
  entailer!.
  unfold_data_at (data_at _ (Tstruct _methods _) _ (gv _foo_methods)).
  rewrite <- mapsto_field_at with (gfs := [StructField _twiddle]) (v:= (gv _foo_twiddle))
  by  auto with field_compatible.
  rewrite field_at_data_at.  rewrite !field_compatible_field_address by auto with field_compatible.
  rewrite !isptr_offset_val_zero by auto.
  cancel.
}

(* 1. Prove that [mtable] is a proper method-table for foo-objects *)

make_func_ptr _foo_twiddle.
make_func_ptr _foo_reset.
sep_apply (make_object_methods Ews foo_invariant(gv _foo_reset) (gv _foo_twiddle) (gv _foo_methods)); auto.

(* 2. Build an instance of class [foo], called [p] *)
forward_call (* p = make_foo(); *)
        gv.
Intros p.
assert_PROP (p<>Vundef) by entailer!.
(* Illustration of an alternate method to prove the method calls.
   Method 1:  comment out lines AA and BB and the entire range CC-DD.
   Method 2:  comment out lines AA-BB, inclusive.
*)

(* AA *) try (tryif
  (method_call (p, @nil Z) (@nil Z) whatever;
   method_call (p, 3, @nil Z) [3%Z] i;
     [simpl; computable | ])
(* BB *)  then fail else fail 99)
  .

(* CC *)
(* 4. first method-call *)
unfold object_mpred.
Intros instance mtable0.
forward. (*  mtable = p->mtable; *)
unfold object_methods at 1.
Intros sh r0 t0.
forward. (* p_reset = mtable->reset; *)
forward_call (* p_reset(p); *)
      (p, @nil Z).
(* Finish the method-call by regathering the object p back together *)
sep_apply (make_object_methods sh instance r0 t0 mtable0); auto.
sep_apply (object_mpred_i [] p instance mtable0).
deadvars!. clear.

(* 5. second method-call *)
unfold object_mpred.
Intros instance mtable0.
forward.  (* mtable = p->mtable; *)
unfold object_methods at 1.
Intros sh r0 t0.
forward.   (* p_twiddle = mtable->twiddle; *)
assert_PROP (p<>Vundef) by entailer!.
forward_call (* i = p_twiddle(p,3); *)
      (p, 3, @nil Z).
  simpl. computable.
Intros i.
simpl in H0.
sep_apply (make_object_methods sh instance r0 t0 mtable0); auto.
sep_apply (object_mpred_i [3] p instance mtable0).
deadvars!.
simpl in H1.

(* DD *)

(* 6. return *)
forward.  (* return i; *)
Exists i; entailer!.
Qed.


(*Generated by Sail from riscv_duopod.*)
Require Import Sail.Base.
Require Import Sail.Real.
Require Import riscv_duopod_types.
Require Import mem_metadata.
Require Import riscv_extras.
Import ListNotations.
Open Scope string.
Open Scope bool.
Open Scope Z.

Definition is_none {a : Type} (opt : option a) : bool :=
   match opt with | Some _ => false | None => true end.

Definition is_some {a : Type} (opt : option a) : bool :=
   match opt with | Some _ => true | None => false end.

Definition eq_unit (_ : unit) (_ : unit) : {_bool : bool & ArithFact (_bool)} := build_ex (true).

Definition neq_int (x : Z) (y : Z) : {_bool : bool & ArithFact (Bool.eqb (negb (x =? y)) _bool)} :=
   build_ex (negb (Z.eqb x y)).

Definition neq_bool (x : bool) (y : bool) : bool := negb (Bool.eqb x y).

Definition __id (x : Z) : {_retval : Z & ArithFact (_retval =? x)} := build_ex (x).

Definition _shl_int_general (m : Z) (n : Z) : Z :=
   if sumbool_of_bool (Z.geb n 0) then shl_int m n else shr_int m (Z.opp n).

Definition _shr_int_general (m : Z) (n : Z) : Z :=
   if sumbool_of_bool (Z.geb n 0) then shr_int m n else shl_int m (Z.opp n).

Definition fdiv_int (n : Z) (m : Z) : Z :=
   if sumbool_of_bool (andb (Z.ltb n 0) (Z.gtb m 0)) then Z.sub (Z.quot (Z.add n 1) m) 1
   else if sumbool_of_bool (andb (Z.gtb n 0) (Z.ltb m 0)) then Z.sub (Z.quot (Z.sub n 1) m) 1
   else Z.quot n m.

Definition fmod_int (n : Z) (m : Z) : Z := Z.sub n (Z.mul m (fdiv_int n m)).

Definition concat_str_bits {n : Z} (str : string) (x : mword n) : string :=
   String.append str (string_of_bits x).

Definition concat_str_dec (str : string) (x : Z) : string := String.append str (dec_str x).

Definition sail_mask {v0 : Z} (len : Z) (v : mword v0) `{ArithFact ((len >=? 0) && (v0 >=? 0))}
: mword len :=
   if sumbool_of_bool (Z.leb len (length_mword v)) then vector_truncate v len else zero_extend v len.

Definition sail_ones (n : Z) `{ArithFact (n >=? 0)} : mword n := not_vec (zeros n).

Definition slice_mask (n : Z) (i : Z) (l : Z) `{ArithFact (n >=? 0)} : mword n :=
   if sumbool_of_bool (Z.geb l n) then shiftl (sail_ones n) i
   else
     let one : bits n := sail_mask n ('b"1"  : bits 1) in
     shiftl (sub_vec (shiftl one l) one) i.

Definition read_kind_of_num (arg_ : Z) `{ArithFact ((0 <=? arg_) && (arg_ <=? 11))} : read_kind :=
   let l__33 := arg_ in
   if sumbool_of_bool (Z.eqb l__33 0) then Read_plain
   else if sumbool_of_bool (Z.eqb l__33 1) then Read_reserve
   else if sumbool_of_bool (Z.eqb l__33 2) then Read_acquire
   else if sumbool_of_bool (Z.eqb l__33 3) then Read_exclusive
   else if sumbool_of_bool (Z.eqb l__33 4) then Read_exclusive_acquire
   else if sumbool_of_bool (Z.eqb l__33 5) then Read_stream
   else if sumbool_of_bool (Z.eqb l__33 6) then Read_RISCV_acquire
   else if sumbool_of_bool (Z.eqb l__33 7) then Read_RISCV_strong_acquire
   else if sumbool_of_bool (Z.eqb l__33 8) then Read_RISCV_reserved
   else if sumbool_of_bool (Z.eqb l__33 9) then Read_RISCV_reserved_acquire
   else if sumbool_of_bool (Z.eqb l__33 10) then Read_RISCV_reserved_strong_acquire
   else Read_X86_locked.

Definition num_of_read_kind (arg_ : read_kind) : {e : Z & ArithFact ((0 <=? e) && (e <=? 11))} :=
   build_ex (
      match arg_ with
      | Read_plain => 0
      | Read_reserve => 1
      | Read_acquire => 2
      | Read_exclusive => 3
      | Read_exclusive_acquire => 4
      | Read_stream => 5
      | Read_RISCV_acquire => 6
      | Read_RISCV_strong_acquire => 7
      | Read_RISCV_reserved => 8
      | Read_RISCV_reserved_acquire => 9
      | Read_RISCV_reserved_strong_acquire => 10
      | Read_X86_locked => 11
      end
   ).

Definition write_kind_of_num (arg_ : Z) `{ArithFact ((0 <=? arg_) && (arg_ <=? 10))} : write_kind :=
   let l__23 := arg_ in
   if sumbool_of_bool (Z.eqb l__23 0) then Write_plain
   else if sumbool_of_bool (Z.eqb l__23 1) then Write_conditional
   else if sumbool_of_bool (Z.eqb l__23 2) then Write_release
   else if sumbool_of_bool (Z.eqb l__23 3) then Write_exclusive
   else if sumbool_of_bool (Z.eqb l__23 4) then Write_exclusive_release
   else if sumbool_of_bool (Z.eqb l__23 5) then Write_RISCV_release
   else if sumbool_of_bool (Z.eqb l__23 6) then Write_RISCV_strong_release
   else if sumbool_of_bool (Z.eqb l__23 7) then Write_RISCV_conditional
   else if sumbool_of_bool (Z.eqb l__23 8) then Write_RISCV_conditional_release
   else if sumbool_of_bool (Z.eqb l__23 9) then Write_RISCV_conditional_strong_release
   else Write_X86_locked.

Definition num_of_write_kind (arg_ : write_kind) : {e : Z & ArithFact ((0 <=? e) && (e <=? 10))} :=
   build_ex (
      match arg_ with
      | Write_plain => 0
      | Write_conditional => 1
      | Write_release => 2
      | Write_exclusive => 3
      | Write_exclusive_release => 4
      | Write_RISCV_release => 5
      | Write_RISCV_strong_release => 6
      | Write_RISCV_conditional => 7
      | Write_RISCV_conditional_release => 8
      | Write_RISCV_conditional_strong_release => 9
      | Write_X86_locked => 10
      end
   ).

Definition a64_barrier_domain_of_num (arg_ : Z) `{ArithFact ((0 <=? arg_) && (arg_ <=? 3))}
: a64_barrier_domain :=
   let l__20 := arg_ in
   if sumbool_of_bool (Z.eqb l__20 0) then A64_FullShare
   else if sumbool_of_bool (Z.eqb l__20 1) then A64_InnerShare
   else if sumbool_of_bool (Z.eqb l__20 2) then A64_OuterShare
   else A64_NonShare.

Definition num_of_a64_barrier_domain (arg_ : a64_barrier_domain)
: {e : Z & ArithFact ((0 <=? e) && (e <=? 3))} :=
   build_ex (
      match arg_ with
      | A64_FullShare => 0
      | A64_InnerShare => 1
      | A64_OuterShare => 2
      | A64_NonShare => 3
      end
   ).

Definition a64_barrier_type_of_num (arg_ : Z) `{ArithFact ((0 <=? arg_) && (arg_ <=? 2))}
: a64_barrier_type :=
   let l__18 := arg_ in
   if sumbool_of_bool (Z.eqb l__18 0) then A64_barrier_all
   else if sumbool_of_bool (Z.eqb l__18 1) then A64_barrier_LD
   else A64_barrier_ST.

Definition num_of_a64_barrier_type (arg_ : a64_barrier_type)
: {e : Z & ArithFact ((0 <=? e) && (e <=? 2))} :=
   build_ex (match arg_ with | A64_barrier_all => 0 | A64_barrier_LD => 1 | A64_barrier_ST => 2 end).

Definition trans_kind_of_num (arg_ : Z) `{ArithFact ((0 <=? arg_) && (arg_ <=? 2))} : trans_kind :=
   let l__16 := arg_ in
   if sumbool_of_bool (Z.eqb l__16 0) then Transaction_start
   else if sumbool_of_bool (Z.eqb l__16 1) then Transaction_commit
   else Transaction_abort.

Definition num_of_trans_kind (arg_ : trans_kind) : {e : Z & ArithFact ((0 <=? e) && (e <=? 2))} :=
   build_ex (
      match arg_ with
      | Transaction_start => 0
      | Transaction_commit => 1
      | Transaction_abort => 2
      end
   ).

Definition cache_op_kind_of_num (arg_ : Z) `{ArithFact ((0 <=? arg_) && (arg_ <=? 10))}
: cache_op_kind :=
   let l__6 := arg_ in
   if sumbool_of_bool (Z.eqb l__6 0) then Cache_op_D_IVAC
   else if sumbool_of_bool (Z.eqb l__6 1) then Cache_op_D_ISW
   else if sumbool_of_bool (Z.eqb l__6 2) then Cache_op_D_CSW
   else if sumbool_of_bool (Z.eqb l__6 3) then Cache_op_D_CISW
   else if sumbool_of_bool (Z.eqb l__6 4) then Cache_op_D_ZVA
   else if sumbool_of_bool (Z.eqb l__6 5) then Cache_op_D_CVAC
   else if sumbool_of_bool (Z.eqb l__6 6) then Cache_op_D_CVAU
   else if sumbool_of_bool (Z.eqb l__6 7) then Cache_op_D_CIVAC
   else if sumbool_of_bool (Z.eqb l__6 8) then Cache_op_I_IALLUIS
   else if sumbool_of_bool (Z.eqb l__6 9) then Cache_op_I_IALLU
   else Cache_op_I_IVAU.

Definition num_of_cache_op_kind (arg_ : cache_op_kind)
: {e : Z & ArithFact ((0 <=? e) && (e <=? 10))} :=
   build_ex (
      match arg_ with
      | Cache_op_D_IVAC => 0
      | Cache_op_D_ISW => 1
      | Cache_op_D_CSW => 2
      | Cache_op_D_CISW => 3
      | Cache_op_D_ZVA => 4
      | Cache_op_D_CVAC => 5
      | Cache_op_D_CVAU => 6
      | Cache_op_D_CIVAC => 7
      | Cache_op_I_IALLUIS => 8
      | Cache_op_I_IALLU => 9
      | Cache_op_I_IVAU => 10
      end
   ).

Definition not_bit (b : bitU) : bitU := if eq_bit b B1 then B0 else B1.

Definition neq_vec {n : Z} (x : mword n) (y : mword n) : bool := negb (eq_vec x y).

Definition string_of_bit (b : bitU) : M (string) :=
   (match b with | B0 => returnm "0b0" | B1 => returnm "0b1" | _ => exit tt  : M (string) end)
    : M (string).

Definition get_config_print_instr '(tt : unit) : bool := false.

Definition get_config_print_reg '(tt : unit) : bool := false.

Definition get_config_print_mem '(tt : unit) : bool := false.

Definition get_config_print_platform '(tt : unit) : bool := false.

Definition EXTS {n : Z} (m : Z) (v : mword n) `{ArithFact (m >=? n)} : mword m := sign_extend v m.

Definition EXTZ {n : Z} (m : Z) (v : mword n) `{ArithFact (m >=? n)} : mword m := zero_extend v m.

Definition zeros_implicit (n : Z) `{ArithFact (n >=? 0)} : mword n := zeros n.

Definition zeros (n : Z) `{ArithFact (n >=? 0)} : mword n :=
   autocast (replicate_bits ('b"0"  : mword 1) n).

Definition ones (n : Z) `{ArithFact (n >=? 0)} : mword n := sail_ones n.

Definition bool_to_bits (x : bool) : mword 1 :=
   if sumbool_of_bool x then 'b"1"  : mword 1 else 'b"0"  : mword 1.

Definition bit_to_bool (b : bitU) : M (bool) :=
   (match b with | B1 => returnm true | B0 => returnm false | _ => exit tt  : M (bool) end)
    : M (bool).

Definition to_bits (l : Z) (n : Z) `{ArithFact (l >=? 0)} : mword l := get_slice_int l n 0.

Definition zopz0zI_s {n : Z} (x : mword n) (y : mword n) `{ArithFact (n >? 0)} : bool :=
   Z.ltb (projT1 (sint x)) (projT1 (sint y)).

Definition zopz0zKzJ_s {n : Z} (x : mword n) (y : mword n) `{ArithFact (n >? 0)} : bool :=
   Z.geb (projT1 (sint x)) (projT1 (sint y)).

Definition zopz0zI_u {n : Z} (x : mword n) (y : mword n) : bool :=
   Z.ltb (projT1 (uint x)) (projT1 (uint y)).

Definition zopz0zKzJ_u {n : Z} (x : mword n) (y : mword n) : bool :=
   Z.geb (projT1 (uint x)) (projT1 (uint y)).

Definition zopz0zIzJ_u {n : Z} (x : mword n) (y : mword n) : bool :=
   Z.leb (projT1 (uint x)) (projT1 (uint y)).

Definition shift_right_arith64 (v : mword 64) (shift : mword 6) : mword 64 :=
   let v128 : bits 128 := EXTS 128 v in
   subrange_vec_dec (shift_bits_right v128 shift) 63 0.

Definition shift_right_arith32 (v : mword 32) (shift : mword 5) : mword 32 :=
   let v64 : bits 64 := EXTS 64 v in
   subrange_vec_dec (shift_bits_right v64 shift) 31 0.

Axiom spc_forwards_matches : forall  (_ : unit) , bool.

Axiom spc_backwards_matches : forall  (_ : string) , bool.

Axiom opt_spc_forwards_matches : forall  (_ : unit) , bool.

Axiom opt_spc_backwards_matches : forall  (_ : string) , bool.

Axiom def_spc_forwards_matches : forall  (_ : unit) , bool.

Axiom def_spc_backwards_matches : forall  (_ : string) , bool.

Axiom hex_bits_forwards : forall {n : Z} (_ : (Z * mword n)) , string.

Axiom hex_bits_backwards : forall {n : Z} (_ : string) , (Z * mword n).

Axiom hex_bits_forwards_matches : forall {n : Z} (_ : (Z * mword n)) , bool.

Axiom hex_bits_backwards_matches : forall  (_ : string) , bool.

Axiom hex_bits_matches_prefix : forall
{n : Z}
(_ : string)
,
option (((Z * mword n) * {n : Z & ArithFact (n >=? 0)})).

Fixpoint _rec_n_leading_spaces (s : string) (_reclimit : Z) (_acc : Acc (Zwf 0) _reclimit)
{struct _acc} : M ({n : Z & ArithFact (n >=? 0)}).
exact (
   assert_exp' (Z.geb _reclimit 0) "recursion limit reached" >>= fun _ =>
   let p0_ := s in
   (if generic_eq p0_ "" then returnm (build_ex 0)
    else
      let p0_ := string_take s 1 in
      (if generic_eq p0_ " " then
         (_rec_n_leading_spaces (string_drop s 1) (Z.sub _reclimit 1) (_limit_reduces _acc)) >>= fun '(existT _ w__0 _ : {n : Z & ArithFact (n >=?
           0)}) =>
         returnm (build_ex (Z.add 1 w__0))
       else returnm (build_ex 0))
       : M ({n : Z & ArithFact (n >=? 0)}))
    : M ({n : Z & ArithFact (n >=? 0)})
).
Defined.

Definition n_leading_spaces (s : string) : M ({n : Z & ArithFact (n >=? 0)}) :=
   (_rec_n_leading_spaces s ((projT1 (string_length s))  : Z) (Zwf_guarded _))
    : M ({n : Z & ArithFact (n >=? 0)}).

Definition spc_forwards '(tt : unit) : string := " ".

Definition spc_backwards (s : string) : unit := tt.

Definition spc_matches_prefix (s : string) : M (option ((unit * {n : Z & ArithFact (n >=? 0)}))) :=
   (n_leading_spaces s) >>= fun '(existT _ n _) =>
   let l__5 := n in
   returnm (if sumbool_of_bool (Z.eqb l__5 0) then None else Some (tt, build_ex n)).

Definition opt_spc_forwards '(tt : unit) : string := "".

Definition opt_spc_backwards (s : string) : unit := tt.

Definition opt_spc_matches_prefix (s : string) : M (option ((unit * {n : Z & ArithFact (n >=? 0)}))) :=
   (n_leading_spaces s) >>= fun '(existT _ w__0 _ : {n : Z & ArithFact (n >=? 0)}) =>
   returnm (Some (tt, build_ex w__0)).

Definition def_spc_forwards '(tt : unit) : string := " ".

Definition def_spc_backwards (s : string) : unit := tt.

Definition def_spc_matches_prefix (s : string) : M (option ((unit * {n : Z & ArithFact (n >=? 0)}))) :=
   (opt_spc_matches_prefix s)  : M (option ((unit * {n : Z & ArithFact (n >=? 0)}))).

Definition rX (r : mword 5) : M (mword 64) :=
   let b__0 := r in
   (if eq_vec b__0 ('b"00000"  : mword 5) then returnm (EXTZ 64 (Ox"0"  : mword 4))
    else
      read_reg Xs_ref >>= fun w__0 : vec (mword 64) 32 =>
      returnm (vec_access_dec w__0 (projT1 (uint r))))
    : M (mword 64).

Definition wX (r : mword 5) (v : mword 64) : M (unit) :=
   (if neq_vec r ('b"00000"  : mword 5) then
      read_reg Xs_ref >>= fun w__0 : vec (mword 64) 32 =>
      write_reg Xs_ref (vec_update_dec w__0 (projT1 (uint r)) v)
       : M (unit)
    else returnm tt)
    : M (unit).

Definition read_mem (addr : mword 64) (width : Z) `{ArithFact (width >=? 0)} : M (mword (8 * width)) :=
   (MEMr 64 width (EXTZ 64 (Ox"0"  : mword 4)) addr)  : M (mword (8 * width)).

Definition iop_of_num (arg_ : Z) `{ArithFact ((0 <=? arg_) && (arg_ <=? 5))} : iop :=
   let l__0 := arg_ in
   if sumbool_of_bool (Z.eqb l__0 0) then RISCV_ADDI
   else if sumbool_of_bool (Z.eqb l__0 1) then RISCV_SLTI
   else if sumbool_of_bool (Z.eqb l__0 2) then RISCV_SLTIU
   else if sumbool_of_bool (Z.eqb l__0 3) then RISCV_XORI
   else if sumbool_of_bool (Z.eqb l__0 4) then RISCV_ORI
   else RISCV_ANDI.

Definition num_of_iop (arg_ : iop) : {e : Z & ArithFact ((0 <=? e) && (e <=? 5))} :=
   build_ex (
      match arg_ with
      | RISCV_ADDI => 0
      | RISCV_SLTI => 1
      | RISCV_SLTIU => 2
      | RISCV_XORI => 3
      | RISCV_ORI => 4
      | RISCV_ANDI => 5
      end
   ).

Definition execute_LOAD (imm : mword 12) (rs1 : mword 5) (rd : mword 5) : M (unit) :=
   (rX rs1) >>= fun w__0 : mword 64 =>
   let addr : xlenbits := add_vec w__0 (EXTS 64 imm) in
   (read_mem addr 8) >>= fun result : xlenbits => (wX rd result)  : M (unit).

Definition execute_ITYPE (arg0 : mword 12) (arg1 : mword 5) (arg2 : mword 5) (arg3 : iop) : M (unit) :=
   let merge_var := (arg0, arg1, arg2, arg3) in
   (match merge_var with
    | (imm, rs1, rd, RISCV_ADDI) =>
       (rX rs1) >>= fun rs1_val =>
       let imm_ext : xlenbits := EXTS 64 imm in
       let result := add_vec rs1_val imm_ext in
       (wX rd result)
        : M (unit)
    | _ => exit tt  : M (unit)
    end)
    : M (unit).

Definition execute (merge_var : ast) : M (unit) :=
   (match merge_var with
    | ITYPE (imm, rs1, rd, arg3) => (execute_ITYPE imm rs1 rd arg3)  : M (unit)
    | LOAD (imm, rs1, rd) => (execute_LOAD imm rs1 rd)  : M (unit)
    end)
    : M (unit).

Definition decode (v__0 : mword 32) : option ast :=
   if andb (eq_vec (subrange_vec_dec v__0 14 12) ('b"000"  : mword (14 - 12 + 1)))
        (eq_vec (subrange_vec_dec v__0 6 0) ('b"0010011"  : mword (6 - 0 + 1))) then
     let imm : bits 12 := subrange_vec_dec v__0 31 20 in
     let rs1 : regbits := subrange_vec_dec v__0 19 15 in
     let rd : regbits := subrange_vec_dec v__0 11 7 in
     let imm : bits 12 := subrange_vec_dec v__0 31 20 in
     Some (ITYPE (imm, rs1, rd, RISCV_ADDI))
   else if andb (eq_vec (subrange_vec_dec v__0 14 12) ('b"011"  : mword (14 - 12 + 1)))
             (eq_vec (subrange_vec_dec v__0 6 0) ('b"0000011"  : mword (6 - 0 + 1))) then
     let imm : bits 12 := subrange_vec_dec v__0 31 20 in
     let rs1 : regbits := subrange_vec_dec v__0 19 15 in
     let rd : regbits := subrange_vec_dec v__0 11 7 in
     let imm : bits 12 := subrange_vec_dec v__0 31 20 in
     Some (LOAD (imm, rs1, rd))
   else None.

Definition initial_regstate : regstate :=
{| Xs :=
     (vec_of_list_len [Ox"0000000000000000"
                        : mword 64;Ox"0000000000000000"  : mword 64;Ox"0000000000000000"  : mword 64;
                       Ox"0000000000000000"
                        : mword 64;Ox"0000000000000000"  : mword 64;Ox"0000000000000000"  : mword 64;
                       Ox"0000000000000000"
                        : mword 64;Ox"0000000000000000"  : mword 64;Ox"0000000000000000"  : mword 64;
                       Ox"0000000000000000"
                        : mword 64;Ox"0000000000000000"  : mword 64;Ox"0000000000000000"  : mword 64;
                       Ox"0000000000000000"
                        : mword 64;Ox"0000000000000000"  : mword 64;Ox"0000000000000000"  : mword 64;
                       Ox"0000000000000000"
                        : mword 64;Ox"0000000000000000"  : mword 64;Ox"0000000000000000"  : mword 64;
                       Ox"0000000000000000"
                        : mword 64;Ox"0000000000000000"  : mword 64;Ox"0000000000000000"  : mword 64;
                       Ox"0000000000000000"
                        : mword 64;Ox"0000000000000000"  : mword 64;Ox"0000000000000000"  : mword 64;
                       Ox"0000000000000000"
                        : mword 64;Ox"0000000000000000"  : mword 64;Ox"0000000000000000"  : mword 64;
                       Ox"0000000000000000"
                        : mword 64;Ox"0000000000000000"  : mword 64;Ox"0000000000000000"  : mword 64;
                       Ox"0000000000000000"
                        : mword 64;Ox"0000000000000000"  : mword 64]);
   nextPC := (Ox"0000000000000000"  : mword 64);
   PC := (Ox"0000000000000000"  : mword 64) |}.
Hint Unfold initial_regstate : sail.