(* This file is an automatic translation, the licence of the source can be found here: *)
(* https://github.com/herd/herdtools7/blob/master/LICENSE.txt *)
(* Translation of model ARM relaxing ppo to accommodate qualcomm behaviors *)
From Coq Require Import Relations Ensembles String.
From RelationAlgebra Require Import lattice prop monoid rel kat.
From Catincoq.lib Require Import Cat proprel.
Section Model.
Variable c : candidate.
Definition events := events c.
Definition R := R c.
Definition W := W c.
Definition IW := IW c.
Definition FW := FW c.
Definition B := B c.
Definition RMW := RMW c.
Definition F := F c.
Definition rf := rf c.
Definition po := po c.
Definition int := int c.
Definition ext := ext c.
Definition loc := loc c.
Definition addr := addr c.
Definition data := data c.
Definition ctrl := ctrl c.
Definition amo := amo c.
Definition rmw := rmw c.
Definition unknown_set := unknown_set c.
Definition unknown_relation := unknown_relation c.
Definition M := R ⊔ W.
Definition emptyset : set events := empty.
Definition classes_loc : set events -> Ensemble (Ensemble events) := partition loc.
Definition X := unknown_set "X".
Definition tag2events := unknown_relation "tag2events".
Definition emptyset_0 : set events := domain 0.
Definition partition := classes_loc.
Definition tag2instrs := tag2events.
Definition po_loc := po ⊓ loc.
Definition rfe := rf ⊓ ext.
Definition rfi := rf ⊓ int.
Definition co0 := loc ⊓ ([IW] ⋅ top ⋅ [(W ⊓ !IW)] ⊔ [(W ⊓ !FW)] ⋅ top ⋅ [FW]).
Definition toid (s : set events) : relation events := [s].
Definition fencerel (B : set events) := (po ⊓ [top] ⋅ top ⋅ [B]) ⋅ po.
Definition ctrlcfence (CFENCE : set events) := (ctrl ⊓ [top] ⋅ top ⋅ [CFENCE]) ⋅ po.
Definition imply (A : relation events) (B : relation events) := !A ⊔ B.
Definition nodetour (R1 : relation events) (R2 : relation events) (R3 : relation events) := R1 ⊓ !(R2 ⋅ R3).
Definition singlestep (R : relation events) := nodetour R R R.
(* Definition of map already included in the prelude *)
Definition LKW := (*failed: try LKW with emptyset_0*) emptyset_0.
(* Definition of co_locs already included in the prelude *)
(* Definition of cross already included in the prelude *)
Definition generate_orders s pco := cross (co_locs pco (partition s)).
Definition generate_cos pco := generate_orders W pco.
Definition cobase := co0.
Variable co : relation events.
Definition coi := co ⊓ int.
Definition coe := co ⊓ !coi.
Definition fr := rf° ⋅ co ⊓ !id.
Definition fri := fr ⊓ int.
Definition fre := fr ⊓ !fri.
Definition poi := po_loc.
Definition complus := fr ⊔ (rf ⊔ (co ⊔ (co ⋅ rf ⊔ fr ⋅ rf))).
Definition scperlocation := irreflexive (poi ⋅ complus).
Definition dd := addr ⊔ data.
Definition rdw := po_loc ⊓ fre ⋅ rfe.
Definition detour := po_loc ⊓ coe ⋅ rfe.
Definition addrpo := addr ⋅ po.
Definition dmb_st : relation events := (*failed: try fencerel DMB.ST with 0*) 0.
Definition dsb_st : relation events := (*failed: try fencerel DSB.ST with 0*) 0.
Definition dmb : relation events := (*failed: try fencerel DMB with 0*) 0.
Definition dsb : relation events := (*failed: try fencerel DSB with 0*) 0.
Definition isb : relation events := (*failed: try fencerel ISB with 0*) 0.
Definition ctrlisb : relation events := (*failed: try ctrlcfence ISB with 0*) 0.
Definition ci0 := ctrlisb ⊔ detour.
Definition ii0 := dd ⊔ (rfi ⊔ rdw).
Definition cc0 := dd ⊔ (ctrl ⊔ (addrpo ⊔ po_loc ⊓ !(rfi ⊔ po_loc ⋅ rfi))).
Definition ic0 : relation events := 0.
Inductive ci : relation _ := ci_c : incl (ci0 ⊔ (ci ⋅ ii ⊔ cc ⋅ ci)) ci
     with ii : relation _ := ii_c : incl (ii0 ⊔ (ci ⊔ (ic ⋅ ci ⊔ ii ⋅ ii))) ii
     with cc : relation _ := cc_c : incl (cc0 ⊔ (ci ⊔ (ci ⋅ ic ⊔ cc ⋅ cc))) cc
     with ic : relation _ := ic_c : incl (ic0 ⊔ (ii ⊔ (cc ⊔ (ic ⋅ cc ⊔ ii ⋅ ic)))) ic.
Section scheme.
Variables ci' ii' cc' ic' : relation events.
Variable Hci' : incl (ci0 ⊔ (ci' ⋅ ii' ⊔ cc' ⋅ ci')) ci'.
Variable Hii' : incl (ii0 ⊔ (ci' ⊔ (ic' ⋅ ci' ⊔ ii' ⋅ ii'))) ii'.
Variable Hcc' : incl (cc0 ⊔ (ci' ⊔ (ci' ⋅ ic' ⊔ cc' ⋅ cc'))) cc'.
Variable Hic' : incl (ic0 ⊔ (ii' ⊔ (cc' ⊔ (ic' ⋅ cc' ⊔ ii' ⋅ ic')))) ic'.

  Fixpoint ci_ind' x y (r : ci x y) : ci' x y
      with ii_ind' x y (r : ii x y) : ii' x y
      with cc_ind' x y (r : cc x y) : cc' x y
      with ic_ind' x y (r : ic x y) : ic' x y.
  Proof.
    destruct r as [x y r]; apply Hci'.
    destruct r as [r | r]; [ left | right ].
     exact r.
     destruct r as [r | r]; [ left | right ].
      destruct r as [x_y r1 r2]; exists x_y.
       apply ci_ind'; exact r1.
       apply ii_ind'; exact r2.
      destruct r as [x_y r1 r2]; exists x_y.
       apply cc_ind'; exact r1.
       apply ci_ind'; exact r2.
    destruct r as [x y r]; apply Hii'.
    destruct r as [r | r]; [ left | right ].
     exact r.
     destruct r as [r | r]; [ left | right ].
      apply ci_ind'; exact r.
      destruct r as [r | r]; [ left | right ].
       destruct r as [x_y r1 r2]; exists x_y.
        apply ic_ind'; exact r1.
        apply ci_ind'; exact r2.
       destruct r as [x_y r1 r2]; exists x_y.
        apply ii_ind'; exact r1.
        apply ii_ind'; exact r2.
    destruct r as [x y r]; apply Hcc'.
    destruct r as [r | r]; [ left | right ].
     exact r.
     destruct r as [r | r]; [ left | right ].
      apply ci_ind'; exact r.
      destruct r as [r | r]; [ left | right ].
       destruct r as [x_y r1 r2]; exists x_y.
        apply ci_ind'; exact r1.
        apply ic_ind'; exact r2.
       destruct r as [x_y r1 r2]; exists x_y.
        apply cc_ind'; exact r1.
        apply cc_ind'; exact r2.
    destruct r as [x y r]; apply Hic'.
    destruct r as [r | r]; [ left | right ].
     exact r.
     destruct r as [r | r]; [ left | right ].
      apply ii_ind'; exact r.
      destruct r as [r | r]; [ left | right ].
       apply cc_ind'; exact r.
       destruct r as [r | r]; [ left | right ].
        destruct r as [x_y r1 r2]; exists x_y.
         apply ic_ind'; exact r1.
         apply cc_ind'; exact r2.
        destruct r as [x_y r1 r2]; exists x_y.
         apply ii_ind'; exact r1.
         apply ic_ind'; exact r2.
  Qed.
End scheme.
Definition ppo := let ppoR := ii ⊓ [R] ⋅ top ⋅ [R] in let ppoW := ic ⊓ [R] ⋅ top ⋅ [W] in ppoR ⊔ ppoW.
Definition WW := [W] ⋅ top ⋅ [W].
Definition dmb_st_0 := dmb_st ⊓ WW.
Definition dsb_st_0 := dsb_st ⊓ WW.
Definition strong := dmb ⊔ (dsb ⊔ (dmb_st_0 ⊔ dsb_st_0)).
Definition light : relation events := 0.
Definition fence := strong ⊔ light.
Definition hb := ppo ⊔ (fence ⊔ rfe).
Definition thinair := acyclic hb.
Definition hbstar := hb^*.
Definition propbase := (fence ⊔ rfe ⋅ fence) ⋅ hbstar.
Definition chapo := rfe ⊔ (fre ⊔ (coe ⊔ (fre ⋅ rfe ⊔ coe ⋅ rfe))).
Definition prop := propbase ⊓ [W] ⋅ top ⋅ [W] ⊔ (chapo ⊔ 1) ⋅ (propbase^* ⋅ (strong ⋅ hbstar)).
Definition propagation := acyclic (co ⊔ prop).
Definition observation := irreflexive (fre ⋅ (prop ⋅ hbstar)).
Definition xx := po ⊓ [X] ⋅ top ⋅ [X].
Definition scXX := acyclic (co ⊔ xx).
Definition witness_conditions := generate_cos cobase co.
Definition model_conditions := scperlocation /\ (thinair /\ (propagation /\ (observation /\ scXX))).
End Model.

Hint Unfold events R W IW FW B RMW F rf po int ext loc addr data ctrl amo rmw unknown_set unknown_relation M emptyset classes_loc X tag2events emptyset_0 partition tag2instrs po_loc rfe rfi co0 toid fencerel ctrlcfence imply nodetour singlestep LKW generate_orders generate_cos cobase coi coe fr fri fre poi complus scperlocation dd rdw detour addrpo dmb_st dsb_st dmb dsb isb ctrlisb ci0 ii0 cc0 ic0 ppo WW dmb_st_0 dsb_st_0 strong light fence hb thinair hbstar propbase chapo prop propagation observation xx scXX witness_conditions model_conditions : cat.

Definition valid (c : candidate) :=
  exists co : relation (events c),
    witness_conditions c co /\
    model_conditions c co.

(* End of translation of model ARM relaxing ppo to accommodate qualcomm behaviors *)


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** RTL function inlining: relational specification *)

Require Import Coqlib Wfsimpl Maps Errors Integers.
Require Import AST Linking.
Require Import Op Registers RTL.
Require Import Inlining.

(** ** Soundness of function environments. *)

(** A compile-time function environment is compatible with a whole
  program if the following condition holds. *)

Definition fenv_compat (p: program) (fenv: funenv) : Prop :=
  forall id f,
  fenv!id = Some f -> (prog_defmap p)!id = Some (Gfun (Internal f)).

Lemma funenv_program_compat:
  forall p, fenv_compat p (funenv_program p).
Proof.
  set (P := fun (dm: PTree.t (globdef fundef unit)) (fenv: funenv) =>
              forall id f,
              fenv!id = Some f -> dm!id = Some (Gfun (Internal f))).
  assert (REMOVE: forall dm fenv id g,
             P dm fenv ->
             P (PTree.set id g dm) (PTree.remove id fenv)).
  { unfold P; intros. rewrite PTree.grspec in H0. destruct (PTree.elt_eq id0 id).
    discriminate.
    rewrite PTree.gso; auto.
  }
  assert (ADD: forall dm fenv idg,
             P dm fenv ->
             P (match snd idg with
                  | Some g => PTree.set (fst idg) g dm
                  | _ => PTree.remove (fst idg) dm
                end) (add_globdef fenv idg)).
  { intros dm fenv [id g]; simpl; intros.
    destruct g as [ [ [f|ef] | v] | ] ; auto.
    destruct (should_inline id f); auto.
    red; intros. rewrite ! PTree.gsspec in *.
    destruct (peq id0 id); auto. inv H0; auto.
    unfold P. intros ? ? .
    rewrite ! PTree.grspec.
    destruct (PTree.elt_eq id0 id); auto.
    discriminate.
  }
  assert (REC: forall l dm fenv,
            P dm fenv ->
            P (fold_left (fun x idg =>
                            match snd idg with
                              | Some g => PTree.set (fst idg) g x
                              | None => PTree.remove (fst idg) x
                            end) l dm)
              (fold_left add_globdef l fenv)).
  { induction l; simpl; intros.
  - auto.
  - apply IHl. apply ADD; auto.
  }
  intros. apply REC. red; intros.  rewrite PTree.gempty in H; discriminate.
Qed.

Lemma fenv_compat_linkorder:
  forall cunit prog fenv,
  linkorder cunit prog -> fenv_compat cunit fenv -> fenv_compat prog fenv.
Proof.
  intros; red; intros. apply H0 in H1.
  destruct (prog_defmap_linkorder _ _ _ _ H H1) as (gd' & P & Q).
  inv Q. inv H3. auto.
Qed.

(** ** Properties of shifting *)

Lemma shiftpos_eq: forall x y, Zpos (shiftpos x y) = (Zpos x + Zpos y) - 1.
Proof.
  intros. unfold shiftpos. zify.  try rewrite Pos2Z.inj_sub. auto.
  zify. omega.
Qed.

Lemma shiftpos_inj:
  forall x y n, shiftpos x n = shiftpos y n -> x = y.
Proof.
  intros.
  assert (Zpos (shiftpos x n) = Zpos (shiftpos y n)) by congruence.
  rewrite ! shiftpos_eq in H0.
  assert (Z.pos x = Z.pos y) by omega.
  congruence.
Qed.

Lemma shiftpos_diff:
  forall x y n, x <> y -> shiftpos x n <> shiftpos y n.
Proof.
  intros; red; intros. elim H. eapply shiftpos_inj; eauto.
Qed.

Lemma shiftpos_above:
  forall x n, Ple n (shiftpos x n).
Proof.
  intros. unfold Ple; zify. rewrite shiftpos_eq. xomega.
Qed.

Lemma shiftpos_not_below:
  forall x n, Plt (shiftpos x n) n -> False.
Proof.
  intros. generalize (shiftpos_above x n). xomega.
Qed.

Lemma shiftpos_below:
  forall x n, Plt (shiftpos x n) (Pplus x n).
Proof.
  intros. unfold Plt; zify. rewrite shiftpos_eq. omega.
Qed.

Lemma shiftpos_le:
  forall x y n, Ple x y -> Ple (shiftpos x n) (shiftpos y n).
Proof.
  intros. unfold Ple in *; zify. rewrite ! shiftpos_eq. omega.
Qed.

(** ** Working with the state monad *)

Remark bind_inversion:
  forall (A B: Type) (f: mon A) (g: A -> mon B)
         (y: B) (s1 s3: state) (i: sincr s1 s3),
  bind f g s1 = R y s3 i ->
  exists x, exists s2, exists i1, exists i2,
  f s1 = R x s2 i1 /\ g x s2 = R y s3 i2.
Proof.
  unfold bind; intros. destruct (f s1). exists x; exists s'; exists I.
  destruct (g x s'). inv H. exists I0; auto.
Qed.

Ltac monadInv1 H :=
  match type of H with
  | (R _ _ _ = R _ _ _) =>
      inversion H; clear H; try subst
  | (ret _ _ = R _ _ _) =>
      inversion H; clear H; try subst
  | (bind ?F ?G ?S = R ?X ?S' ?I) =>
      let x := fresh "x" in (
      let s := fresh "s" in (
      let i1 := fresh "INCR" in (
      let i2 := fresh "INCR" in (
      let EQ1 := fresh "EQ" in (
      let EQ2 := fresh "EQ" in (
      destruct (bind_inversion _ _ F G X S S' I H) as [x [s [i1 [i2 [EQ1 EQ2]]]]];
      clear H;
      try (monadInv1 EQ2)))))))
  end.

Ltac monadInv H :=
  match type of H with
  | (ret _ _ = R _ _ _) => monadInv1 H
  | (bind ?F ?G ?S = R ?X ?S' ?I) => monadInv1 H
  | (?F _ _ _ _ _ _ _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ _ _ _ _ _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ _ _ _ _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ _ _ _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ _ _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  end.

Fixpoint mlist_iter2 {A B: Type} (f: A -> B -> mon unit) (l: list (A*B)): mon unit :=
  match l with
  | nil => ret tt
  | (x,y) :: l' => do z <- f x y; mlist_iter2 f l'
  end.

Remark mlist_iter2_fold:
  forall (A B: Type) (f: A -> B -> mon unit) l s,
  exists i,
  mlist_iter2 f l s =
  R tt (fold_left (fun a p => match f (fst p) (snd p) a with R _ s2 _ => s2 end) l s) i.
Proof.
  induction l; simpl; intros.
  exists (sincr_refl s); auto.
  destruct a as [x y]. unfold bind. simpl. destruct (f x y s) as [xx s1 i1].
  destruct (IHl s1) as [i2 EQ]. rewrite EQ. econstructor; eauto.
Qed.

Lemma ptree_mfold_spec:
  forall (A: Type) (f: positive -> A -> mon unit) t s x s' i,
  ptree_mfold f t s = R x s' i ->
  exists i', mlist_iter2 f (PTree.elements t) s = R tt s' i'.
Proof.
  intros.
  destruct (mlist_iter2_fold _ _ f (PTree.elements t) s) as [i' EQ].
  unfold ptree_mfold in H. inv H. rewrite PTree.fold_spec.
  econstructor. eexact EQ.
Qed.

(** ** Relational specification of the translation of moves *)

Inductive tr_moves (c: code) : node -> list reg -> list reg -> node -> Prop :=
  | tr_moves_cons: forall pc1 src srcs dst dsts pc2 pc3,
      tr_moves c pc1 srcs dsts pc2 ->
      c!pc2 = Some(Iop Omove (src :: nil) dst pc3) ->
      tr_moves c pc1 (src :: srcs) (dst :: dsts) pc3
  | tr_moves_nil: forall srcs dsts pc,
      srcs = nil \/ dsts = nil ->
      tr_moves c pc srcs dsts pc.

Lemma add_moves_unchanged:
  forall srcs dsts pc2 s pc1 s' i pc,
  add_moves srcs dsts pc2 s = R pc1 s' i ->
  Plt pc s.(st_nextnode) \/ Ple s'.(st_nextnode) pc ->
  s'.(st_code)!pc = s.(st_code)!pc.
Proof.
  induction srcs; simpl; intros.
  monadInv H. auto.
  destruct dsts; monadInv H. auto.
  transitivity (st_code s0)!pc. eapply IHsrcs; eauto. monadInv EQ; simpl. xomega.
  monadInv EQ; simpl. apply PTree.gso.
  inversion INCR0; simpl in *. xomega.
Qed.

Lemma add_moves_spec:
  forall srcs dsts pc2 s pc1 s' i c,
  add_moves srcs dsts pc2 s = R pc1 s' i ->
  (forall pc, Ple s.(st_nextnode) pc -> Plt pc s'.(st_nextnode) -> c!pc = s'.(st_code)!pc) ->
  tr_moves c pc1 srcs dsts pc2.
Proof.
  induction srcs; simpl; intros.
  monadInv H. apply tr_moves_nil; auto.
  destruct dsts; monadInv H. apply tr_moves_nil; auto.
  apply tr_moves_cons with x. eapply IHsrcs; eauto.
  intros. inversion INCR. apply H0; xomega.
  monadInv EQ.
  rewrite H0. erewrite add_moves_unchanged; eauto.
  simpl. apply PTree.gss.
  simpl. xomega.
  xomega.
  inversion INCR; inversion INCR0; simpl in *; xomega.
Qed.

(** ** Relational specification of CFG expansion *)

Section INLINING_SPEC.

Variable fenv: funenv.

Definition context_below (ctx1 ctx2: context): Prop :=
  Ple (Pplus ctx1.(dreg) ctx1.(mreg)) ctx2.(dreg).

Definition context_stack_call (ctx1 ctx2: context): Prop :=
  ctx1.(mstk) >= 0 /\ ctx1.(dstk) + ctx1.(mstk) <= ctx2.(dstk).

Definition context_stack_tailcall (ctx1: context) (f: function) (ctx2: context) : Prop :=
  ctx2.(dstk) = align ctx1.(dstk) (min_alignment f.(fn_stacksize)).

Section INLINING_BODY_SPEC.

Variable stacksize: Z.

Inductive tr_instr: context -> node -> instruction -> code -> Prop :=
  | tr_nop: forall ctx pc c s,
      c!(spc ctx pc) = Some (Inop (spc ctx s)) ->
      tr_instr ctx pc (Inop s) c
  | tr_op: forall ctx pc c op args res s,
      Ple res ctx.(mreg) ->
      c!(spc ctx pc) = Some (Iop (sop ctx op) (sregs ctx args) (sreg ctx res) (spc ctx s)) ->
      tr_instr ctx pc (Iop op args res s) c
  | tr_load: forall ctx pc c chunk addr args res s,
      Ple res ctx.(mreg) ->
      c!(spc ctx pc) = Some (Iload chunk (saddr ctx addr) (sregs ctx args) (sreg ctx res) (spc ctx s)) ->
      tr_instr ctx pc (Iload chunk addr args res s) c
  | tr_store: forall ctx pc c chunk addr args src s,
      c!(spc ctx pc) = Some (Istore chunk (saddr ctx addr) (sregs ctx args) (sreg ctx src) (spc ctx s)) ->
      tr_instr ctx pc (Istore chunk addr args src s) c
  | tr_call: forall ctx pc c sg ros args res s,
      Ple res ctx.(mreg) ->
      c!(spc ctx pc) = Some (Icall sg (sros ctx ros) (sregs ctx args) (sreg ctx res) (spc ctx s)) ->
      tr_instr ctx pc (Icall sg ros args res s) c
  | tr_call_inlined:forall ctx pc sg id args res s c f pc1 ctx',
      Ple res ctx.(mreg) ->
      fenv!id = Some f ->
      c!(spc ctx pc) = Some(Inop pc1) ->
      tr_moves c pc1 (sregs ctx args) (sregs ctx' f.(fn_params)) (spc ctx' f.(fn_entrypoint)) ->
      tr_funbody ctx' f c ->
      ctx'.(retinfo) = Some(spc ctx s, sreg ctx res) ->
      context_below ctx ctx' ->
      context_stack_call ctx ctx' ->
      tr_instr ctx pc (Icall sg (inr _ id) args res s) c
  | tr_tailcall: forall ctx pc c sg ros args,
      c!(spc ctx pc) = Some (Itailcall sg (sros ctx ros) (sregs ctx args)) ->
      ctx.(retinfo) = None ->
      tr_instr ctx pc (Itailcall sg ros args) c
  | tr_tailcall_call: forall ctx pc c sg ros args res s,
      c!(spc ctx pc) = Some (Icall sg (sros ctx ros) (sregs ctx args) res s) ->
      ctx.(retinfo) = Some(s, res) ->
      tr_instr ctx pc (Itailcall sg ros args) c
  | tr_tailcall_inlined: forall ctx pc sg id args c f pc1 ctx',
      fenv!id = Some f ->
      c!(spc ctx pc) = Some(Inop pc1) ->
      tr_moves c pc1 (sregs ctx args) (sregs ctx' f.(fn_params)) (spc ctx' f.(fn_entrypoint)) ->
      tr_funbody ctx' f c ->
      ctx'.(retinfo) = ctx.(retinfo) ->
      context_below ctx ctx' ->
      context_stack_tailcall ctx f ctx' ->
      tr_instr ctx pc (Itailcall sg (inr _ id) args) c
  | tr_builtin: forall ctx pc c ef args res s,
      match res with BR r => Ple r ctx.(mreg) | _ => True end ->
      c!(spc ctx pc) = Some (Ibuiltin ef (map (sbuiltinarg ctx) args) (sbuiltinres ctx res) (spc ctx s)) ->
      tr_instr ctx pc (Ibuiltin ef args res s) c
  | tr_cond: forall ctx pc cond args s1 s2 c,
      c!(spc ctx pc) = Some (Icond cond (sregs ctx args) (spc ctx s1) (spc ctx s2)) ->
      tr_instr ctx pc (Icond cond args s1 s2) c
  | tr_jumptable: forall ctx pc r tbl c,
      c!(spc ctx pc) = Some (Ijumptable (sreg ctx r) (List.map (spc ctx) tbl)) ->
      tr_instr ctx pc (Ijumptable r tbl) c
  | tr_return: forall ctx pc or c,
      c!(spc ctx pc) = Some (Ireturn (option_map (sreg ctx) or)) ->
      ctx.(retinfo) = None ->
      tr_instr ctx pc (Ireturn or) c
  | tr_return_inlined: forall ctx pc or c rinfo,
      c!(spc ctx pc) = Some (inline_return ctx or rinfo) ->
      ctx.(retinfo) = Some rinfo ->
      tr_instr ctx pc (Ireturn or) c

with tr_funbody: context -> function -> code -> Prop :=
  | tr_funbody_intro: forall ctx f c,
      (forall r, In r f.(fn_params) -> Ple r ctx.(mreg)) ->
      (forall pc i, f.(fn_code)!pc = Some i -> tr_instr ctx pc i c) ->
      ctx.(mstk) = Zmax f.(fn_stacksize) 0 ->
      (min_alignment f.(fn_stacksize) | ctx.(dstk)) ->
      ctx.(dstk) >= 0 -> ctx.(dstk) + ctx.(mstk) <= stacksize ->
      tr_funbody ctx f c.

Definition fenv_agree (fe: funenv) : Prop :=
  forall id f, fe!id = Some f -> fenv!id = Some f.

Section EXPAND_INSTR.

Variable fe: funenv.
Hypothesis FE: fenv_agree fe.

Variable rec: forall fe', (size_fenv fe' < size_fenv fe)%nat -> context -> function -> mon unit.

Hypothesis rec_unchanged:
  forall fe' (L: (size_fenv fe' < size_fenv fe)%nat) ctx f s x s' i pc,
  rec fe' L ctx f s = R x s' i ->
  Ple ctx.(dpc) s.(st_nextnode) ->
  Plt pc ctx.(dpc) ->
  s'.(st_code)!pc = s.(st_code)!pc.

Remark set_instr_other:
  forall pc instr s x s' i pc',
  set_instr pc instr s = R x s' i ->
  pc' <> pc ->
  s'.(st_code)!pc' = s.(st_code)!pc'.
Proof.
  intros. monadInv H; simpl. apply PTree.gso; auto.
Qed.

Remark set_instr_same:
  forall pc instr s x s' i c,
  set_instr pc instr s = R x s' i ->
  c!(pc) = s'.(st_code)!pc ->
  c!(pc) = Some instr.
Proof.
  intros. rewrite H0. monadInv H; simpl. apply PTree.gss.
Qed.

Lemma expand_instr_unchanged:
  forall ctx pc instr s x s' i pc',
  expand_instr fe rec ctx pc instr s = R x s' i ->
  Ple ctx.(dpc) s.(st_nextnode) ->
  Plt pc' s.(st_nextnode) ->
  pc' <> spc ctx pc ->
  s'.(st_code)!pc' = s.(st_code)!pc'.
Proof.
  generalize set_instr_other; intros A.
  intros. unfold expand_instr in H; destruct instr; eauto.
(* call *)
  destruct (can_inline fe s1). eauto.
  monadInv H. unfold inline_function in EQ. monadInv EQ.
  transitivity (s2.(st_code)!pc'). eauto.
  transitivity (s5.(st_code)!pc'). eapply add_moves_unchanged; eauto.
    left. inversion INCR5. inversion INCR3. monadInv EQ1; simpl in *. xomega.
  transitivity (s4.(st_code)!pc'). eapply rec_unchanged; eauto.
    simpl. monadInv EQ; simpl. monadInv EQ1; simpl. xomega.
    simpl. monadInv EQ1; simpl. auto.
  monadInv EQ; simpl. monadInv EQ1; simpl. auto.
(* tailcall *)
  destruct (can_inline fe s1).
  destruct (retinfo ctx) as [[rpc rreg]|]; eauto.
  monadInv H. unfold inline_tail_function in EQ. monadInv EQ.
  transitivity (s2.(st_code)!pc'). eauto.
  transitivity (s5.(st_code)!pc'). eapply add_moves_unchanged; eauto.
    left. inversion INCR5. inversion INCR3. monadInv EQ1; simpl in *. xomega.
  transitivity (s4.(st_code)!pc'). eapply rec_unchanged; eauto.
    simpl. monadInv EQ; simpl. monadInv EQ1; simpl. xomega.
    simpl. monadInv EQ1; simpl. auto.
  monadInv EQ; simpl. monadInv EQ1; simpl. auto.
(* return *)
  destruct (retinfo ctx) as [[rpc rreg]|]; eauto.
Qed.

Lemma iter_expand_instr_unchanged:
  forall ctx pc l s x s' i,
  mlist_iter2 (expand_instr fe rec ctx) l s = R x s' i ->
  Ple ctx.(dpc) s.(st_nextnode) ->
  Plt pc s.(st_nextnode) ->
  ~In pc (List.map (spc ctx) (List.map (@fst _ _) l)) ->
  list_norepet (List.map (@fst _ _) l) ->
  s'.(st_code)!pc = s.(st_code)!pc.
Proof.
  induction l; simpl; intros.
  (* base case *)
  monadInv H. auto.
  (* inductive case *)
  destruct a as [pc1 instr1]; simpl in *.
  monadInv H. inv H3.
  transitivity ((st_code s0)!pc).
  eapply IHl; eauto. destruct INCR; xomega. destruct INCR; xomega.
  eapply expand_instr_unchanged; eauto.
Qed.

Lemma expand_cfg_rec_unchanged:
  forall ctx f s x s' i pc,
  expand_cfg_rec fe rec ctx f s = R x s' i ->
  Ple ctx.(dpc) s.(st_nextnode) ->
  Plt pc ctx.(dpc) ->
  s'.(st_code)!pc = s.(st_code)!pc.
Proof.
  intros. unfold expand_cfg_rec in H. monadInv H. inversion EQ.
  transitivity ((st_code s0)!pc).
  exploit ptree_mfold_spec; eauto. intros [INCR' ITER].
  eapply iter_expand_instr_unchanged; eauto.
    subst s0; auto.
    subst s0; simpl. xomega.
    red; intros. exploit list_in_map_inv; eauto. intros [pc1 [A B]].
    subst pc. unfold spc in H1. eapply shiftpos_not_below; eauto.
    apply PTree.elements_keys_norepet.
  subst s0; auto.
Qed.

Hypothesis rec_spec:
  forall fe' (L: (size_fenv fe' < size_fenv fe)%nat) ctx f s x s' i c,
  rec fe' L ctx f s = R x s' i ->
  fenv_agree fe' ->
  Ple (ctx.(dpc) + max_pc_function f) s.(st_nextnode) ->
  ctx.(mreg) = max_reg_function f ->
  Ple (Pplus ctx.(dreg) ctx.(mreg)) s.(st_nextreg) ->
  ctx.(mstk) >= 0 ->
  ctx.(mstk) = Zmax (fn_stacksize f) 0 ->
  (min_alignment (fn_stacksize f) | ctx.(dstk)) ->
  ctx.(dstk) >= 0 ->
  s'.(st_stksize) <= stacksize ->
  (forall pc, Ple ctx.(dpc) pc -> Plt pc s'.(st_nextnode) -> c!pc = s'.(st_code)!pc) ->
  tr_funbody ctx f c.

Remark min_alignment_pos:
  forall sz, min_alignment sz > 0.
Proof.
  intros; unfold min_alignment.
  destruct (zle sz 1). omega. destruct (zle sz 2). omega. destruct (zle sz 4); omega.
Qed.

Ltac inv_incr :=
  match goal with
  | [ H: sincr _ _ |- _ ] => destruct H; inv_incr
  | _ => idtac
  end.

Lemma expand_instr_spec:
  forall ctx pc instr s x s' i c,
  expand_instr fe rec ctx pc instr s = R x s' i ->
  (forall r, instr_defs instr = Some r -> Ple r ctx.(mreg)) ->
  Plt (spc ctx pc) s.(st_nextnode) ->
  Ple (ctx.(dreg) + ctx.(mreg)) s.(st_nextreg) ->
  ctx.(mstk) >= 0 -> ctx.(dstk) >= 0 ->
  s'.(st_stksize) <= stacksize ->
  (forall pc', Ple s.(st_nextnode) pc' -> Plt pc' s'.(st_nextnode) -> c!pc' = s'.(st_code)!pc') ->
  c!(spc ctx pc) = s'.(st_code)!(spc ctx pc) ->
  tr_instr ctx pc instr c.
Proof.
  intros until c; intros EXP DEFS OPC OREG STK1 STK2 STK3 S1 S2.
  generalize set_instr_same; intros BASE.
  unfold expand_instr in EXP; destruct instr; simpl in DEFS;
  try (econstructor; eauto; fail).
(* call *)
  destruct (can_inline fe s1) as [|id f P Q].
  (* not inlined *)
  eapply tr_call; eauto.
  (* inlined *)
  subst s1.
  monadInv EXP. unfold inline_function in EQ; monadInv EQ.
  set (ctx' := callcontext ctx x1 x2 (max_reg_function f) (fn_stacksize f) n r).
  inversion EQ0; inversion EQ1; inversion EQ. inv_incr.
  apply tr_call_inlined with (pc1 := x0) (ctx' := ctx') (f := f); auto.
  eapply BASE; eauto.
  eapply add_moves_spec; eauto.
    intros. rewrite S1. eapply set_instr_other; eauto. unfold node; xomega.
    xomega. xomega.
  eapply rec_spec; eauto.
    red; intros. rewrite PTree.grspec in H. destruct (PTree.elt_eq id0 id); try discriminate. auto.
    simpl. subst s2; simpl in *; xomega.
    simpl. subst s3; simpl in *; xomega.
    simpl. xomega.
    simpl. apply align_divides. apply min_alignment_pos.
    assert (dstk ctx + mstk ctx <= dstk ctx'). simpl. apply align_le. apply min_alignment_pos. omega.
    omega.
    intros. simpl in H. rewrite S1.
    transitivity (s1.(st_code)!pc0). eapply set_instr_other; eauto. unfold node in *; xomega.
    eapply add_moves_unchanged; eauto. unfold node in *; xomega. xomega.
  red; simpl. subst s2; simpl in *. xomega.
  red; simpl. split. auto. apply align_le. apply min_alignment_pos.
(* tailcall *)
  destruct (can_inline fe s1) as [|id f P Q].
  (* not inlined *)
  destruct (retinfo ctx) as [[rpc rreg] | ] eqn:?.
  (* turned into a call *)
  eapply tr_tailcall_call; eauto.
  (* preserved *)
  eapply tr_tailcall; eauto.
  (* inlined *)
  subst s1.
  monadInv EXP. unfold inline_function in EQ; monadInv EQ.
  set (ctx' := tailcontext ctx x1 x2 (max_reg_function f) (fn_stacksize f)) in *.
  inversion EQ0; inversion EQ1; inversion EQ. inv_incr.
  apply tr_tailcall_inlined with (pc1 := x0) (ctx' := ctx') (f := f); auto.
  eapply BASE; eauto.
  eapply add_moves_spec; eauto.
    intros. rewrite S1. eapply set_instr_other; eauto. unfold node; xomega. xomega. xomega.
  eapply rec_spec; eauto.
    red; intros. rewrite PTree.grspec in H. destruct (PTree.elt_eq id0 id); try discriminate. auto.
    simpl. subst s3; simpl in *. subst s2; simpl in *. xomega.
    simpl. subst s3; simpl in *; xomega.
    simpl. xomega.
    simpl. apply align_divides. apply min_alignment_pos.
    assert (dstk ctx <= dstk ctx'). simpl. apply align_le. apply min_alignment_pos. omega.
    omega.
    intros. simpl in H. rewrite S1.
    transitivity (s1.(st_code))!pc0. eapply set_instr_other; eauto. unfold node in *; xomega.
    eapply add_moves_unchanged; eauto. unfold node in *; xomega. xomega.
  red; simpl.
subst s2; simpl in *; xomega.
  red; auto.
(* builtin *)
  eapply tr_builtin; eauto. destruct b; eauto.
(* return *)
  destruct (retinfo ctx) as [[rpc rreg] | ] eqn:?.
  (* inlined *)
  eapply tr_return_inlined; eauto.
  (* unchanged *)
  eapply tr_return; eauto.
Qed.

Lemma iter_expand_instr_spec:
  forall ctx l s x s' i c,
  mlist_iter2 (expand_instr fe rec ctx) l s = R x s' i ->
  list_norepet (List.map (@fst _ _) l) ->
  (forall pc instr r, In (pc, instr) l -> instr_defs instr = Some r -> Ple r ctx.(mreg)) ->
  (forall pc instr, In (pc, instr) l -> Plt (spc ctx pc) s.(st_nextnode)) ->
  Ple (ctx.(dreg) + ctx.(mreg)) s.(st_nextreg) ->
  ctx.(mstk) >= 0 -> ctx.(dstk) >= 0 ->
  s'.(st_stksize) <= stacksize ->
  (forall pc', Ple s.(st_nextnode) pc' -> Plt pc' s'.(st_nextnode) -> c!pc' = s'.(st_code)!pc') ->
  (forall pc instr, In (pc, instr) l -> c!(spc ctx pc) = s'.(st_code)!(spc ctx pc)) ->
  forall pc instr, In (pc, instr) l -> tr_instr ctx pc instr c.
Proof.
  induction l; simpl; intros.
  (* base case *)
  contradiction.
  (* inductive case *)
  destruct a as [pc1 instr1]; simpl in *. inv H0. monadInv H. inv_incr.
  assert (A: Ple ctx.(dpc) s0.(st_nextnode)).
    assert (B: Plt (spc ctx pc) (st_nextnode s)) by eauto.
    unfold spc in B. generalize (shiftpos_above pc (dpc ctx)). xomega.
  destruct H9. inv H.
  (* same pc *)
  eapply expand_instr_spec; eauto.
  omega.
  intros.
    transitivity ((st_code s')!pc').
    apply H7. auto. xomega.
    eapply iter_expand_instr_unchanged; eauto.
    red; intros. rewrite list_map_compose in H9. exploit list_in_map_inv; eauto.
    intros [[pc0 instr0] [P Q]]. simpl in P.
    assert (Plt (spc ctx pc0) (st_nextnode s)) by eauto. xomega.
  transitivity ((st_code s')!(spc ctx pc)).
    eapply H8; eauto.
    eapply iter_expand_instr_unchanged; eauto.
    assert (Plt (spc ctx pc) (st_nextnode s)) by eauto. xomega.
    red; intros. rewrite list_map_compose in H. exploit list_in_map_inv; eauto.
    intros [[pc0 instr0] [P Q]]. simpl in P.
    assert (pc = pc0) by (eapply shiftpos_inj; eauto). subst pc0.
    elim H12. change pc with (fst (pc, instr0)). apply List.in_map; auto.
  (* older pc *)
  inv_incr. eapply IHl; eauto.
  intros. eapply Plt_le_trans. eapply H2. right; eauto. xomega.
  intros; eapply Ple_trans; eauto.
  intros. apply H7; auto. xomega.
Qed.

Lemma expand_cfg_rec_spec:
  forall ctx f s x s' i c,
  expand_cfg_rec fe rec ctx f s = R x s' i ->
  Ple (ctx.(dpc) + max_pc_function f) s.(st_nextnode) ->
  ctx.(mreg) = max_reg_function f ->
  Ple (ctx.(dreg) + ctx.(mreg)) s.(st_nextreg) ->
  ctx.(mstk) >= 0 ->
  ctx.(mstk) = Zmax (fn_stacksize f) 0 ->
  (min_alignment (fn_stacksize f) | ctx.(dstk)) ->
  ctx.(dstk) >= 0 ->
  s'.(st_stksize) <= stacksize ->
  (forall pc', Ple ctx.(dpc) pc' -> Plt pc' s'.(st_nextnode) -> c!pc' = s'.(st_code)!pc') ->
  tr_funbody ctx f c.
Proof.
  intros. unfold expand_cfg_rec in H. monadInv H. inversion EQ.
  constructor.
  intros. rewrite H1. eapply max_reg_function_params; eauto.
  intros. exploit ptree_mfold_spec; eauto. intros [INCR' ITER].
  eapply iter_expand_instr_spec; eauto.
    apply PTree.elements_keys_norepet.
    intros. rewrite H1. eapply max_reg_function_def with (i := instr); eauto.
    eapply PTree.elements_complete; eauto.
  intros.
    assert (Ple pc0 (max_pc_function f)).
      eapply max_pc_function_sound. eapply PTree.elements_complete; eauto.
      eapply Plt_le_trans. apply shiftpos_below. subst s0; simpl; xomega.
  subst s0; simpl; auto.
  intros. apply H8; auto. subst s0; simpl in H11; xomega.
  intros. apply H8. apply shiftpos_above.
  assert (Ple pc0 (max_pc_function f)).
    eapply max_pc_function_sound. eapply PTree.elements_complete; eauto.
  eapply Plt_le_trans. apply shiftpos_below. inversion i; xomega.
  apply PTree.elements_correct; auto.
  auto. auto. auto.
  inversion INCR0. subst s0; simpl in STKSIZE; xomega.
Qed.

End EXPAND_INSTR.

Lemma expand_cfg_unchanged:
  forall fe ctx f s x s' i pc,
  expand_cfg fe ctx f s = R x s' i ->
  Ple ctx.(dpc) s.(st_nextnode) ->
  Plt pc ctx.(dpc) ->
  s'.(st_code)!pc = s.(st_code)!pc.
Proof.
  intros fe0; pattern fe0. apply well_founded_ind with (R := ltof _ size_fenv).
  apply well_founded_ltof.
  intros. unfold expand_cfg in H0. rewrite unroll_Fixm in H0.
  eapply expand_cfg_rec_unchanged; eauto. assumption.
Qed.

Lemma expand_cfg_spec:
  forall fe ctx f s x s' i c,
  expand_cfg fe ctx f s = R x s' i ->
  fenv_agree fe ->
  Ple (ctx.(dpc) + max_pc_function f) s.(st_nextnode) ->
  ctx.(mreg) = max_reg_function f ->
  Ple (ctx.(dreg) + ctx.(mreg)) s.(st_nextreg) ->
  ctx.(mstk) >= 0 ->
  ctx.(mstk) = Zmax (fn_stacksize f) 0 ->
  (min_alignment (fn_stacksize f) | ctx.(dstk)) ->
  ctx.(dstk) >= 0 ->
  s'.(st_stksize) <= stacksize ->
  (forall pc', Ple ctx.(dpc) pc' -> Plt pc' s'.(st_nextnode) -> c!pc' = s'.(st_code)!pc') ->
  tr_funbody ctx f c.
Proof.
  intros fe0; pattern fe0. apply well_founded_ind with (R := ltof _ size_fenv).
  apply well_founded_ltof.
  intros. unfold expand_cfg in H0. rewrite unroll_Fixm in H0.
  eapply expand_cfg_rec_spec; eauto.
  simpl. intros. eapply expand_cfg_unchanged; eauto. assumption.
Qed.

End INLINING_BODY_SPEC.

End INLINING_SPEC.

(** ** Relational specification of the translation of a function *)

Inductive tr_function: program -> function -> function -> Prop :=
  | tr_function_intro: forall p fenv f f' ctx,
      fenv_compat p fenv ->
      tr_funbody fenv f'.(fn_stacksize) ctx f f'.(fn_code) ->
      ctx.(dstk) = 0 ->
      ctx.(retinfo) = None ->
      f'.(fn_sig) = f.(fn_sig) ->
      f'.(fn_params) = sregs ctx f.(fn_params) ->
      f'.(fn_entrypoint) = spc ctx f.(fn_entrypoint) ->
      0 <= fn_stacksize f' < Ptrofs.max_unsigned ->
      tr_function p f f'.

Lemma tr_function_linkorder:
  forall cunit prog f f',
  linkorder cunit prog ->
  tr_function cunit f f' ->
  tr_function prog f f'.
Proof.
  intros. inv H0. econstructor; eauto. eapply fenv_compat_linkorder; eauto.
Qed.

Lemma transf_function_spec:
  forall cunit f f',
  transf_function (funenv_program cunit) f = OK f' ->
  tr_function cunit f f'.
Proof.
  intros. unfold transf_function in H.
  set (fenv := funenv_program cunit) in *.
  destruct (expand_function fenv f initstate) as [ctx s i] eqn:?.
  destruct (zlt (st_stksize s) Ptrofs.max_unsigned); inv H.
  monadInv Heqr. set (ctx := initcontext x x0 (max_reg_function f) (fn_stacksize f)) in *.
Opaque initstate.
  destruct INCR3. inversion EQ1. inversion EQ.
  apply tr_function_intro with fenv ctx; auto.
  apply funenv_program_compat.
  eapply expand_cfg_spec with (fe := fenv); eauto.
    red; auto.
    unfold ctx; rewrite <- H1; rewrite <- H2; rewrite <- H3; simpl. xomega.
    unfold ctx; rewrite <- H0; rewrite <- H1; simpl. xomega.
    simpl. xomega.
    simpl. apply Zdivide_0.
    simpl. omega.
  simpl. omega.
  simpl. split; auto. destruct INCR2. destruct INCR1. destruct INCR0. destruct INCR.
  simpl. change 0 with (st_stksize initstate). omega.
Qed.


From iVM Require Export StateRel.
Require Import Coq.Logic.ProofIrrelevance.

Unset Suggest Proof Using.

(** We leave these assumptions abstract in order improve proof search.
    In Concete.v we have shown that they hold in our standard model. *)
Declare Instance MP1: MachineParams1.
Declare Instance MP2: MachineParams2.
Include CoreRel.

(** ** Basic monotonicity *)

(** Additional assumptions *)
Declare Instance RM X (RX: Rel X) : Rel (M X).
Declare Instance PM : SMonadPropR State M (RM:=RM).

Proposition bind_propr'
            {X Y} {RX: Rel X} {RY: Rel Y}
            {mx mx': M X} (Hmx: mx ⊑ mx')
            {f f': X -> M Y} (Hf: f ⊑ f') : mx >>= f ⊑ mx' >>= f'.
Proof.
  exact (bind_propr State M RX RY mx mx' Hmx f f' Hf).
Qed.

Ltac crush0 :=
  match goal with
  | [ |- ret _ ⊑ ret _ ] => unshelve eapply ret_propr; [apply PM|]
  | [|- err ⊑ _] => unshelve eapply err_least, PM
  | [ |- get ⊑ get ] => unshelve eapply get_propr, PM
  | [ |- put _ ⊑ put _ ] => unshelve eapply put_propr; [apply PM|]

  | [|- ?x ⊑ ?x] => try reflexivity;
                  unshelve eapply propR;
                  match goal with [|- PropR x] => fail end

  | [H : rel eq_relation ?x ?y |- _] => cbv in H; first [subst x|subst y]

  | [|- rel (option_relation _) None _] => exact I
  | [H: rel (option_relation _) (Some _) None |- _] => destruct H
  | [x: _ * _ |- _] => destruct x; simpl fst; simpl snd
  | [H: rel (prod_relation _ _) _ _ |- _] => destruct H

  | [|- rel (fun_relation _ _) ?a _] =>
    match type of a with
    | State -> _ =>
      let x := fresh "s" in
      let y := fresh "t" in
      let Hxy := fresh "Hst" in
      intros x y Hxy
    | Image _ -> _ =>
      let x := fresh "i" in
      let y := fresh "j" in
      let Hxy := fresh "Hij" in
      intros x y Hxy
    | Memory -> _ => (* TODO: Merge with next case *)
      let x := fresh "f" in
      let y := fresh "g" in
      let Hxy := fresh "Hfg" in
      intros x y Hxy
    | (_ -> _) -> _ =>
      let x := fresh "f" in
      let y := fresh "g" in
      let Hxy := fresh "Hfg" in
      intros x y Hxy
    | _ -> _ =>
      let x := fresh "x" in
      let y := fresh "y" in
      let Hxy := fresh "Hxy" in
      intros x y Hxy
    end

  | [|- match ?H with left _ => _ | right _ => _ end ⊑ _] =>
    let HL := fresh "HL" in
    let HR := fresh "HR" in
    destruct H as [HL|HR]

  | [|- _ ⊑ match ?H with left _ => _ | right _ => _ end] =>
    let HL := fresh "HL" in
    let HR := fresh "HR" in
    destruct H as [HL|HR]

  | [|- (match ?H with left _ => _ | right _ => _ end) >>= _ ⊑ _] =>
    let HL := fresh "HL" in
    let HR := fresh "HR" in
    destruct H as [HL|HR];
    [ repeat rewrite ret_bind
    | repeat rewrite err_bind ]

  | [|- _ ⊑ (match ?H with left _ => _ | right _ => _ end) >>= _] =>
    let HL := fresh "HL" in
    let HR := fresh "HR" in
    destruct H as [HL|HR];
    [ repeat rewrite ret_bind
    | repeat rewrite err_bind ]

  | [|- match ?H with Some _ => _ | None => _ end ⊑ _] =>
    let u := fresh "u" in
    let Hu := fresh "Hu" in
    destruct H as [u|] eqn:Hu

  | [|- _ ⊑ match ?H with Some _ => _ | None => _ end] =>
    let v := fresh "v" in
    let Hv := fresh "Hv" in
    destruct H as [v|] eqn:Hv

  | [|- rel memory_relation _ _] =>
    let a := fresh "a" in
    let Ha := fresh "Ha" in
    intros a Ha

  | [ |- (_ >>= _) >>= _ ⊑ _ ] => setoid_rewrite bind_assoc
  | [ |- _ ⊑ (_ >>= _) >>= _ ] => setoid_rewrite bind_assoc
  | [ |- _ >>= _ ⊑ _ >>= _ ] => apply bind_propr'

  | _ => exact eq_refl
  | _ => progress unfold PropR
  end.

(** TODO: Useful? *)
Instance assume_propr P {DP: Decidable P} : PropR (assume P).
Proof.
  repeat crush0.
Qed.

(** *** Get *)

Local Ltac get_tactic :=
  rewrite get_spec; simpl; repeat crush0;
  match goal with [ H: _ ⊑ _ |- _ ] => srel_destruct H end;
  try assumption.

Instance getMem_propr : PropR (get' MEM).
Proof. get_tactic. apply Hst_mem. Qed.

Instance getImg_propr : PropR (get' OUT_IMAGE).
Proof. get_tactic. Qed.

Instance getByt_propr: PropR (get' OUT_BYTES).
Proof. get_tactic. Qed.

Instance getChr_propr: PropR (get' OUT_CHARS).
Proof. get_tactic. Qed.

Instance getSnd_propr: PropR (get' OUT_SOUND).
Proof. get_tactic. Qed.

Instance getLog_propr: PropR (get' LOG).
Proof. get_tactic. Qed.

Instance getInp_propr: PropR (get' INP).
Proof. get_tactic. Qed.

Instance getPc_propr: PropR (get' PC).
Proof. get_tactic. Qed.

Instance getSp_propr: PropR (get' SP).
Proof. get_tactic. Qed.

(** *** Put *)

Local Ltac put_tactic :=
  rewrite put_spec; simpl; repeat crush0;
  match goal with [ H: _ ⊑ _ |- _ ] => srel_destruct H end;
  repeat split;
  unfold lens_relation;
  repeat (lens_rewrite1 || simpl);
  reflexivity || assumption.

Instance putMem_propr : PropR (put' MEM).
Proof. put_tactic. Qed.

Instance putImg_propr : PropR (put' OUT_IMAGE).
Proof. put_tactic. Qed.

Instance putByt_propr: PropR (put' OUT_BYTES).
Proof. put_tactic. Qed.

Instance putChr_propr: PropR (put' OUT_CHARS).
Proof. put_tactic. Qed.

Instance putSnd_propr: PropR (put' OUT_SOUND).
Proof. put_tactic. Qed.

Instance putLog_propr: PropR (put' LOG).
Proof. put_tactic. Qed.

Instance putInp_propr: PropR (put' INP).
Proof. put_tactic. Qed.

Instance putPc_propr: PropR (put' PC).
Proof. put_tactic. Qed.

Instance putSp_propr: PropR (put' SP).
Proof. put_tactic. Qed.

(** *** Crush *)

Ltac crush1 :=
  match goal with
  | [|- put' MEM _ ⊑ put' MEM _] => unshelve eapply putMem_propr
  | [|- put' OUT_IMAGE _ ⊑ put' OUT_IMAGE _] => unshelve eapply putImg_propr
  | [|- put' OUT_BYTES _ ⊑ put' OUT_BYTES _] => unshelve eapply putByt_propr
  | [|- put' OUT_CHARS _ ⊑ put' OUT_CHARS _] => unshelve eapply putChr_propr
  | [|- put' OUT_SOUND _ ⊑ put' OUT_SOUND _] => unshelve eapply putSnd_propr
  | [|- put' LOG _ ⊑ put' LOG _] => unshelve eapply putLog_propr
  | [|- put' INP _ ⊑ put' INP _] => unshelve eapply putInp_propr
  | [|- put' PC _ ⊑ put' PC _] => unshelve eapply putPc_propr
  | [|- put' SP _ ⊑ put' SP _] => unshelve eapply putSp_propr

  | _ => crush0
  end.

Ltac crush := repeat crush1.

Instance pointwise_propr {X Y} (f: X -> Y) {RY: Rel Y} (H: forall x, PropR (f x)) : PropR f.
Proof. crush. Qed.

(** In other words, there is no less of generality instatiating
arguments for which the relation is simply [eq]. On the contrary, this
improves proof search. *)

(** ** Monotone operations *)

Instance extr_propr {X} {RX: Rel X} : PropR (extr (X:=X)).
Proof.
  rewrite extr_spec.
  crush.
  exact Hxy.
Qed.

Instance load_propr a : PropR (load a).
Proof.
  rewrite load_spec.
  crush.
  apply extr_propr, Hfg.
Qed.

Instance loadMany_propr n a : PropR (loadMany n a).
Proof.
  revert a; induction n; intros a; simp loadMany; crush.
Qed.

Instance next_propr n : PropR (next n).
Proof. induction n; simp next; crush. Qed.

Instance store_propr a o : PropR (store a o).
Proof.
  rewrite store_spec.
  crush.
  apply Hfg.
Qed.

Instance storeMany_propr a lst : PropR (storeMany a lst).
Proof.
  revert a.
  induction lst as [|x r IH]; intros a;
    simp storeMany; crush.
Qed.

Instance push_propr u : PropR (push u).
Proof.
  rewrite push_spec.
  crush.
Qed.

Instance pushManyR_propr u : PropR (pushManyR u).
Proof.
  induction u; simp pushManyR; crush.
Qed.

Instance pushMany_propr u : PropR (pushMany u).
Proof. rewrite pushMany_spec. crush. Qed.

Instance pop_propr : PropR pop.
Proof.
  rewrite pop_spec. crush.
Qed.

Instance popMany_propr n : PropR (popMany n).
Proof.
  induction n; simp popMany; crush.
Qed.

Instance pop64_propr: PropR pop64.
Proof. unfold pop64. crush. Qed.

Instance pushZ_propr z: PropR (pushZ z).
Proof. unfold pushZ. crush. Qed.

Instance storeZ_propr n a z : PropR (storeZ n a z).
Proof. unfold storeZ. crush. Qed.

Local Open Scope N.

Instance setPixel_propr x y c : PropR (setPixel x y c).
Proof.
  rewrite setPixel_spec. unfold updatePixel.
  crush;
    destruct Hij as [Hw [Hh Hi]];
    [ | congruence | congruence ].
  exists Hw. exists Hh. intros x' Hx' y' Hy'. simpl.
  destruct (decide (x' = x /\ y' = y)).
  - reflexivity.
  - exact (Hi x' Hx' y' Hy').
Qed.

Instance readPixel_propr x y : PropR (readPixel x y).
Proof. rewrite readPixel_spec. crush. Qed.

Lemma image_complete_lemma
      {i i': Image (option OutputColor)}
      (Hi: i ⊑ i') (Hc: image_complete i) : i = i'.
Proof.
  destruct i as [w h p].
  destruct i' as [w' h' p'].
  destruct Hi as [Hw [Hh Hp]].
  simpl in *. subst w'. subst h'.
  apply f_equal.
  extensionality x. extensionality Hx.
  extensionality y. extensionality Hy.
  specialize (Hp x Hx y Hy). simpl in Hp.
  specialize (Hc x Hx y Hy). simpl in Hc.
  rewrite <- (some_extract Hc) in *.
  destruct (p' x Hx y Hy) as [c'|].
  - unfold rel in Hp.
    destruct (extract Hc) as [[r g] b].
    destruct c' as [[r' g'] b'].
    cbn in Hp.
    destruct Hp as [[Hr Hg] Hb].
    crush.
  - crush.
Qed.

Instance newFrame_propr w h r: PropR (newFrame w h r).
Proof.
  rewrite newFrame_spec, extractImage_spec.
  crush; destruct (image_complete_lemma Hij HL).
  - destruct (proof_irrelevance _ HL HL0). reflexivity.
  - contradict HR. exact HL.
Qed.

Close Scope N.

(** ** Monotone steps *)

#[global] Instance oneStep_propr : PropR oneStep.
Proof.
  unfold oneStep. crush.
  destruct (y: Z) eqn:Hy;
    [ crush; reflexivity | | simp oneStep'; crush].

  (* Is there a more elegant way to do this. *)
  unfold oneStep'.
  repeat (match goal with
            [|- context [match _ with xI _ => _ | xO _ => _ | xH => _ end]] =>
            destruct p end).
  all:
    try rewrite putByte_spec;
    try rewrite putChar_spec;
    try rewrite addSample_spec;
    try rewrite readFrame_spec;
    crush.
Qed.

#[global] Instance nSteps_propr n : PropR (nSteps n).
Proof.
  induction n; simp nSteps; unfold chain; crush.
  destruct y; crush.
Qed.


(** This module proves that the stream transducer semantics defined in
module [Streams] is safe (cf. Theorem 3.2 in the paper). *)

From Coq Require Import Program.Equality Omega.
From SimplyRatt Require Export Streams FundamentalProperty.

From SimplyRatt Require Import Tactics.

Import ListNotations.

(** This is part (i) of Theorem 3.2 in the paper. *)
Theorem causality1 A B k t :
  vtype A ->
  ctx_empty ⊢ t ∶ Box (Arrow (Str A) (Str B)) ->
  trrel A B k (app (unbox t) (adv (ref thel)),heap_empty).
Proof.
  intros VTA Ty. constructor; eauto using closed_heap_empty, typed_closed, heap_empty_fresh.
  intros v w V W.
  assert (ctx_lock ctx_empty ⊢ unbox t ∶ Arrow (Str A) (Str B)) as Ty' by eauto.
  eapply fund_prop with (g:= nil) (Hs := (str_heapseq A k))
                        (s := store_lock (Some (heap_single thel (v ∷ ref thel)))
                                         (heap_single thel (w ∷ ref thel)))
    in Ty';eauto. rewrite sub_empty_app in Ty' by auto. eapply trel_app;
  eauto using typed_closed. eapply trel_adv. auto using mapsto_heap_cons.
  apply vrel_trel. autorewrite with vrel. eexists. split. reflexivity. simpl.
  autorewrite with vrel. do 2 eexists. split. reflexivity. split.
  rewrite vtype_tsubst by auto. eauto using vtype_vrel.
  eapply vrel_mono; try eapply thel_vrel;eauto.
  eapply crel_lock;eauto using str_heapseq_closed.
  eauto using str_heapseq_closed.
  constructor;  eauto using vtype_vrel_closed,closed_heap_alloc, closed_heap_empty.
Qed.

(** This is part (ii) of Theorem 3.2 in the paper. *)
Theorem causality2 A B k s v :
  vtype A -> isvalue v -> ctx_empty ⊢ v ∶ A ->
  trrel A B (S k) s -> exists v' s', tred s v v' s' /\ trrel A B k s'.
Proof.
  intros VTA V Ty TR. inversion TR;subst.
  apply typing_vtype with (Hs:=[]) (s:=store_bot) in Ty; eauto.
  pose (vtype_inhab _ VTA) as W. destruct W as (w&W).
  assert (exists (v' : term) (s : store),
  {t, (store_lock (Some (heap_cons h thel (v ∷ ref thel))) (heap_single thel (w ∷ ref thel)))}⇓ {v', s} /\
  vrel Str (B) (str_heapseq (A) (S k)) s v') as Red.
  eapply H1 with (v:=v); try eassumption;eauto using tick_le_refl,str_heapseq_closed.
  constructor; eauto using vtype_vrel_closed,closed_heap_alloc,closed_heap_empty.

  destruct Red as (v'& s&R&VR).

  pose (red_extensive _ _ _ _ R) as SL. dependent destruction SL.
  eapply red_not_later with (u:=unit) in R; eauto using heap_dom_cons'.
  rewrite heap_cons_eq in R.
  autorewrite with vrel in VR. simpl in VR. destruct VR as (v'' & E & VR). subst.
  autorewrite with vrel in VR. simpl in VR. destruct VR as (v1 & v2 & E & VR). subst.

  do 2 eexists. split. econstructor. apply R. constructor.
  - assert (heap_mapsto thel (w ∷ ref thel) h2') by eauto using mapsto_heap_cons.
    assert (closed_term (w ∷ ref thel)) by eauto using vtype_vrel_closed.
    assert (closed_heap (heap_cons h2' thel unit)). apply red_closed in R;eauto.
    destruct R as [C1 C2]. inversion C2. auto.
    constructor;eauto using closed_heap_empty,closed_heap_alloc,vtype_vrel_closed.
    eauto using closed_heap_cons_rev.
  - destruct VR; eauto using vrel_delay_closed.
  - intros.

    assert (exists (v' : term) (s : store),
               {t, (store_lock (Some (heap_cons h thel (v ∷ ref thel))) (heap_single thel (v0 ∷ ref thel)))}⇓ {v', s} /\
               vrel Str (B) (str_heapseq (A) (S k)) s v') as Red2.

    eapply H1 with (v:=v) (w:=v0); try eassumption;eauto using tick_le_refl,str_heapseq_closed.
  constructor; eauto using vtype_vrel_closed,closed_heap_alloc,closed_heap_empty.

  destruct Red2 as (v'& s&R'&VR').

  pose (red_extensive _ _ _ _ R') as SL. dependent destruction SL.
  eapply red_not_later with (u:=unit) in R'; eauto using heap_dom_cons'.
  rewrite heap_cons_eq in R'.

  pose (red_determ _ _ _ _ _ _ R R') as D. destruct D as [E D]. subst.
  dependent destruction D.

  autorewrite with vrel in VR'. simpl in VR'. destruct VR' as (v'' & E & VR'). subst.
  autorewrite with vrel in VR'. simpl in VR'. destruct VR' as (v1' & v2' & E' & VR1 & VR2). subst.
  dependent destruction E.
  autorewrite with vrel in VR2.  autodest. simpl in H11.
  assert (heap_cons h2' thel (v0 ∷ ref thel) = h2'0) as HR by
        (eapply heap_overwrite; eauto using mapsto_heap_cons).
  rewrite HR.
  dependent destruction H9. eapply trel_adv;eauto.
  eapply H10. constructor. eauto using vtype_vrel_closed. assumption.
Qed.


(******************************************************************************)
(* PipeCheck: Specifying and Verifying Microarchitectural                     *)
(* Enforcement of Memory Consistency Models                                   *)
(*                                                                            *)
(* Copyright (c) 2014 Daniel Lustig, Princeton University                     *)
(* All rights reserved.                                                       *)
(*                                                                            *)
(* This library is free software; you can redistribute it and/or              *)
(* modify it 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 library is distributed in the hope that it will be useful,            *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU          *)
(* Lesser General Public License for more details.                            *)
(*                                                                            *)
(* You should have received a copy of the GNU Lesser General Public           *)
(* License along with this library; if not, write to the Free Software        *)
(* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  *)
(* USA                                                                        *)
(******************************************************************************)

Require Import List.
Import ListNotations.
Require Import util2.
Require Import Ascii.
Require Import String.

(* ** GraphTree

A [GraphTree] is a data structure which is used to represent a set of
  graphs that are mostly similar, but with a few small differences.  For
  example, suppose we want to represent two graphs: one which adds an edge e1
  to a graph G, and another which adds a different edge e2 to G.  Rather than
  representing these as {G + e1, G + e2}, a [GraphTree] would represent them
  as G + {e1 or e2}.

  The motivation for a [GraphTree] is to more easily represent the case in
  which, for example, a litmus test outcome may be observable in any one of
  a number of possible graphs, some of which will generally look very similar.
  *)
Inductive GraphTree (A : Type) : Type :=
  | GraphTreeOr   : list (GraphTree A) -> GraphTree A
  | GraphTreeAnd  : list (GraphTree A) -> GraphTree A
  | GraphTreeLeaf : string -> list (A * A * string) -> GraphTree A.

Open Scope string_scope.
Open Scope list_scope.

Definition GraphTreeEmptyLeaf {A : Type} := GraphTreeLeaf A "" [].

(** The [DNFOfTree] of a [GraphTree] is an explicit list of the graphs
  represented by the tree, i.e., no longer in the compacted [GraphTree]
  format. *)
Fixpoint DNFOfTree {A : Type}
  (t : GraphTree A)
  : list (string * list (A * A * string)) :=
  let joinGraphs {A : Type}
    (a b : string * list (A * A * string))
    : string * list (A * A * string) :=
    let (an, al) := a in
    let (bn, bl) := b in
    (append an bn, al ++ bl)
  in
  match t with
  | GraphTreeOr l =>
    fold_left (app (A:=_)) (map DNFOfTree l) []
  | GraphTreeAnd l =>
    let l' := map DNFOfTree l in
    map (fun x => fold_left joinGraphs x ("", [])) (CartesianProduct l')
  | GraphTreeLeaf n g => [(n, g)]
  end.

(** [GraphTreeSimplify] tries to represent a [GraphTree] in a simpler but
  equivalent form.  It does not guarantee minimality. *)
Fixpoint GraphTreeSimplify {A : Type}
  (g : GraphTree A)
  : GraphTree A :=
  match g with
  | GraphTreeOr    [x] => GraphTreeSimplify x
  | GraphTreeOr     l  => GraphTreeOr _ (map GraphTreeSimplify l)
  | GraphTreeAnd   [x] => GraphTreeSimplify x
  | GraphTreeAnd    l  => GraphTreeAnd _ (map GraphTreeSimplify l)
  | _ => g
  end.

Lemma SimplifiedDNF {A : Type} : forall (g : GraphTree A),
  DNFOfTree (GraphTreeSimplify g) = DNFOfTree g.
Proof.
(* TODO: http://adam.chlipala.net/cpdt/html/InductiveTypes.html *)
Abort.

(** [TreeOfDNF] converts a list of graphs into [GraphTree] representation. *)
Definition TreeOfDNF {A : Type}
  (l : list (string * list (A * A * string)))
  : GraphTree A :=
  let f x := GraphTreeLeaf _ (fst x) (snd x) in
  GraphTreeSimplify (GraphTreeOr _ (map f l)).

Lemma fold1 {A : Type} : forall l (x : list A),
  fold_left (app (A:=_)) l x = x ++ fold_left (app (A:=_)) l [].
Proof.
  intros l.  induction l.
    intros x.  simpl.  rewrite app_nil_r.  auto.
  intros x.  simpl.  rewrite IHl.  symmetry.  rewrite IHl.
  rewrite app_assoc.  auto.
Qed.

Lemma fold2 {A : Type} : forall l (xh : A) (xt : list A),
  fold_left (app (A:=_)) l (xh::xt) = xh :: fold_left (app (A:=_)) l xt.
Proof.
Admitted.

Lemma DNFIdempotent {A : Type} :
  forall x,
  forall (l : list (string * list (A * A * string))),
  In x l -> In x (DNFOfTree (TreeOfDNF l)).
Proof.
  intros x.  induction l as [|lh lt].
    auto.
  intros Hx.  destruct Hx as [Hx|Hx].
    rewrite Hx in *; clear Hx.
    unfold TreeOfDNF.  unfold map.  unfold GraphTreeSimplify.  simpl.
    destruct lt.
      simpl.  left.  destruct x; auto.
    simpl.  rewrite fold1.  left.  destruct x; auto.
  apply IHlt in Hx.  clear IHlt.

  destruct lt.
    inversion Hx.
  simpl.  rewrite fold2.  right.
  destruct lt as [|lth ltt].
    simpl in *.  auto.
  simpl in *.  auto.
Qed.

Module TreeExample.

Example e1 :
  DNFOfTree
  (GraphTreeAnd _ [
    GraphTreeLeaf _ "A" [(1, 2, "a")];
    GraphTreeLeaf _ "B" [(3, 4, "b")]
  ])
  = [("AB", [(1, 2, "a"); (3, 4, "b")])].
Proof.
cbv.  auto.
Qed.

Example e2 :
  DNFOfTree
  (GraphTreeAnd _ [
    GraphTreeLeaf _ "A" [(1, 2, "a")];
    GraphTreeOr _ [
      GraphTreeLeaf _ "B" [(3, 4, "b")];
      GraphTreeLeaf _ "C" [(5, 6, "c")]
    ]
  ])
  = [("AB", [(1, 2, "a"); (3, 4, "b")]); ("AC", [(1, 2, "a"); (5, 6, "c")])].
Proof.
cbv.  auto.
Qed.

Example e3 :
  DNFOfTree
  (GraphTreeAnd _ [
    GraphTreeLeaf _ "A" [(1, 2, "a")];
    GraphTreeLeaf _ "B" [(7, 8, "d")];
    GraphTreeOr _ [
      GraphTreeLeaf _ "C" [(3, 4, "b")];
      GraphTreeLeaf _ "D" [(5, 6, "c")]
    ]
  ])
  = [("ABC", [(1, 2, "a"); (7, 8, "d"); (3, 4, "b")]);
     ("ABD", [(1, 2, "a"); (7, 8, "d"); (5, 6, "c")])].
Proof.
cbv.  auto.
Qed.

Example e4 :
  DNFOfTree
  (GraphTreeAnd _ [
    GraphTreeLeaf _ "A" [(1, 2, "a")];
    GraphTreeAnd _ [
      GraphTreeEmptyLeaf;
      GraphTreeLeaf _ "B" [(3, 4, "b")]
    ]
  ])
  = [("AB", [(1, 2, "a"); (3, 4, "b")])].
Proof.
cbv.  auto.
Qed.

Example e5 :
  DNFOfTree
  (GraphTreeAnd _ [
    GraphTreeLeaf _ "A" [(1, 2, "a")];
    GraphTreeOr _ []
  ])
  = [].
Proof.
unfold DNFOfTree.  unfold map.
cbv.  auto.
Qed.

End TreeExample.

Definition DNFStringOfTree' {A : Type}
  (print_node : A -> string)
  (e : A * A * string)
  : string :=
  let (sd, label) := e in
  let (s, d) := sd in
  fold_left append [": "; print_node s; "-"; label; "->"; print_node d; " "] "".

Fixpoint DNFStringOfTree {A : Type}
  (print_node : A -> string)
  (t : GraphTree A)
  : string :=
  let f_fold a b := append b (append "-" a) in
  match t with
  | GraphTreeOr l =>
    append "Or(" (append (fold_left f_fold (map (DNFStringOfTree print_node) l) "") ")")
  | GraphTreeAnd l =>
    append "And(" (append (fold_left f_fold (map (DNFStringOfTree print_node) l) "") ")")
  | GraphTreeLeaf n l => fold_left append (map (DNFStringOfTree' print_node) l) n
  end.

Close Scope string_scope.

Fixpoint GraphTreeMap {A B : Type}
  (f : A -> B)
  (g : GraphTree A)
  : GraphTree B :=
  match g with
  | GraphTreeAnd    l => GraphTreeAnd  _ (map (GraphTreeMap f) l)
  | GraphTreeOr     l => GraphTreeOr   _ (map (GraphTreeMap f) l)
  | GraphTreeLeaf n l =>
    let f' x := (f (fst (fst x)), f (snd (fst x)), snd x) in
    GraphTreeLeaf _ n (map f' l)
  end.

Fixpoint GraphTreeMapPair {A B : Type}
  (f : A * A * string -> B * B * string)
  (g : GraphTree A)
  : GraphTree B :=
  match g with
  | GraphTreeAnd    l => GraphTreeAnd  _ (map (GraphTreeMapPair f) l)
  | GraphTreeOr     l => GraphTreeOr   _ (map (GraphTreeMapPair f) l)
  | GraphTreeLeaf n l =>
    GraphTreeLeaf _ n (map f l)
  end.


(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
Require Import Qcanon.
Require Export base orders separation_instances.
Local Open Scope Qc_scope.

(**
Concrete permissions are built from more primitive combinators:
- [lockable]: [Locked] describes that the object has been locked due to
  a sequenced write, and [Unlocked] means that it is not locked
- [counter] is to account for tokens to keep track of parts of the memory
  that are addresseble.
*)
Definition perm := (lockable (counter Qcanon.Qc) + Qcanon.Qc)%type.
#[global] Instance perm_sep_ops : SeparationOps perm := _.
#[global] Instance perm_sep : Separation perm := _.
Typeclasses Opaque perm.
Global Hint Extern 0 (Separation _) => apply (_ : Separation perm): core.

Definition perm_readonly : perm := inr 1.
Definition perm_full : perm := inl (LUnlocked (Counter 0 1)).
Definition perm_token : perm := inl (LUnlocked (Counter (-1) ∅)).

Inductive pkind :=
  Writable | Readable | Locked | Existing.
#[global] Instance pkind_dec (k1 k2 : pkind) : Decision (k1 = k2).
Proof. solve_decision. Defined.
#[global] Instance pkind_subseteq : SubsetEq pkind := λ k1 k2,
  match k1, k2 with
  | _, Writable => True
  | (Existing | Readable), Readable => True
  | Existing, Existing => True
  | (Existing | Locked), Locked => True
  | _, _ => False
  end.
#[global] Instance pkind_subseteq_dec : ∀ k1 k2 : pkind, Decision (k1 ⊆ k2).
Proof. intros [] []; apply _. Defined.
#[global] Instance: PartialOrder (@subseteq pkind _).
Proof. by repeat split; repeat intros []. Qed.
#[global] Instance option_pkind_subseteq : SubsetEq (option pkind) := λ k1 k2,
  match k1, k2 with
  | Some k1, Some k2 => k1 ⊆ k2 | None, _ => True | Some _, None => False
  end.
#[global] Instance option_pkind_subseteq_dec : ∀ k1 k2 : option pkind, Decision (k1 ⊆ k2).
Proof. intros [] []; apply _. Defined.
#[global] Instance: PartialOrder (@subseteq (option pkind) _).
Proof. by repeat split; repeat intros []; try destruct p; try destruct p0; try destruct p1. Qed.

Definition perm_kind (γ : perm) : option pkind :=
  match γ with
  | inl (LUnlocked (Counter x' y')) =>
     if decide (y' = ∅) then
       if decide (x' = 0) then None else Some Existing
     else if decide (y' = 1) then Some Writable else Some Readable
  | inl (LLocked _) => Some Locked
  | inr x' => Some Readable
  end.
Definition perm_locked (γ : perm) : bool :=
  match γ with inl (LLocked _) => true | _ => false end.
Definition perm_lock (γ : perm) : perm :=
  match γ with inl (LUnlocked x') => inl (LLocked x') | _ => γ end.
Definition perm_unlock (γ : perm) : perm :=
  match γ with inl (LLocked x') => inl (LUnlocked x') | _ => γ end.

Inductive perm_kind_view : perm → option pkind → Prop :=
  | perm_kind_None : perm_kind_view (inl (LUnlocked (Counter ∅ 0))) None
  | perm_kind_Locked x' : perm_kind_view (inl (LLocked x')) (Some Locked)
  | perm_kind_Existing x' :
     x' ≠ 0 → perm_kind_view (inl (LUnlocked (Counter x' ∅))) (Some Existing)
  | perm_kind_Readable x' y' :
     y' ≠ ∅ → y' ≠ 1 →
     perm_kind_view (inl (LUnlocked (Counter x' y'))) (Some Readable)
  | perm_kind_Writable x' :
     perm_kind_view (inl (LUnlocked (Counter x' 1))) (Some Writable)
  | perm_kind_Writable' x' :
     x' ≠ 0 → perm_kind_view (inl (LUnlocked (Counter x' 1))) (Some Writable)
  | perm_kind_ro_Readable x' : perm_kind_view (inr x') (Some Readable).
Lemma perm_kind_spec γ : perm_kind_view γ (perm_kind γ).
Proof.
  destruct γ as [[[]|[]]|]; simpl; repeat case_decide;
    intuition; simplify_equality'; constructor; auto.
Qed.
Arguments perm_kind _ : simpl never.

Lemma perm_full_valid : sep_valid perm_full.
Proof. done. Qed.
Lemma perm_full_mapped : ¬sep_unmapped perm_full.
Proof. by apply (bool_decide_unpack _). Qed.
Lemma perm_full_unshared : sep_unshared perm_full.
Proof. by apply (bool_decide_unpack _). Qed.
Lemma perm_subseteq_full γ1 γ2 : γ1 = perm_full → γ1 ⊆ γ2 → γ2 = perm_full.
Proof.
  intros ->; destruct γ2 as [[[??]|[c x]]|?];
    repeat sep_unfold; unfold perm_full; intuition; simplify_equality.
  assert (x = 1) as -> by eauto using Qcle_antisym.
  by assert (c = 0) as -> by eauto using Qcle_antisym.
Qed.
Lemma perm_readonly_valid : sep_valid perm_readonly.
Proof. done. Qed.
Lemma perm_readonly_mapped : ¬sep_unmapped perm_readonly.
Proof. by apply (bool_decide_unpack _). Qed.
Lemma perm_token_valid : sep_valid perm_token.
Proof. done. Qed.
Lemma perm_locked_mapped γ : perm_locked γ = true → ¬sep_unmapped γ.
Proof. destruct γ as [[[]|]|[]]; repeat sep_unfold; naive_solver. Qed.
Lemma perm_Readable_locked γ :
  Some Readable ⊆ perm_kind γ → perm_locked γ = false.
Proof. by destruct (perm_kind_spec γ). Qed.
Lemma perm_locked_lock γ :
  Some Writable ⊆ perm_kind γ → perm_locked (perm_lock γ) = true.
Proof. by destruct (perm_kind_spec γ). Qed.
Lemma perm_locked_unlock γ : perm_locked (perm_unlock γ) = false.
Proof. by destruct γ as [[]|[]]. Qed.
Lemma perm_lock_valid γ :
  sep_valid γ → Some Writable ⊆ perm_kind γ → sep_valid (perm_lock γ).
Proof. destruct (perm_kind_spec γ); repeat sep_unfold; intuition. Qed.
Lemma perm_lock_empty γ : perm_lock γ = ∅ → γ = ∅.
Proof. by destruct γ as [[]|?]. Qed.
Lemma perm_lock_unmapped γ :
  Some Writable ⊆ perm_kind γ → sep_unmapped γ → sep_unmapped (perm_lock γ).
Proof. destruct (perm_kind_spec γ); repeat sep_unfold; naive_solver. Qed.
Lemma perm_lock_mapped γ : sep_unmapped (perm_lock γ) → sep_unmapped γ.
Proof. destruct γ as [[]|[]]; repeat sep_unfold; intuition. Qed.
Lemma perm_lock_unshared γ : sep_unshared γ → sep_unshared (perm_lock γ).
Proof. destruct γ as [[]|[]]; repeat sep_unfold; intuition. Qed.
Lemma perm_unlock_lock γ :
  sep_valid γ → Some Writable ⊆ perm_kind γ → perm_unlock (perm_lock γ) = γ.
Proof. by destruct (perm_kind_spec γ). Qed.
Lemma perm_unlock_unlock γ : perm_unlock (perm_unlock γ) = perm_unlock γ.
Proof. by destruct γ as [[]|]. Qed.
Lemma perm_unlock_valid γ : sep_valid γ → sep_valid (perm_unlock γ).
Proof. destruct γ as [[[]|[]]|]; repeat sep_unfold; naive_solver. Qed.
Lemma perm_unlock_empty γ : sep_valid γ → perm_unlock γ = ∅ → γ = ∅.
Proof. destruct γ as [[]|?]; repeat sep_unfold; naive_solver. Qed.
Lemma perm_unlock_unmapped γ : sep_unmapped γ → sep_unmapped (perm_unlock γ).
Proof. destruct γ as [[[]|[]]|]; repeat sep_unfold; intuition. Qed.
Lemma perm_unlock_mapped γ :
  sep_valid γ → sep_unmapped (perm_unlock γ) → sep_unmapped γ.
Proof. destruct γ as [[[]|[]]|[]]; repeat sep_unfold; naive_solver. Qed.
Lemma perm_unlock_unshared γ : sep_unshared γ → sep_unshared (perm_unlock γ).
Proof. destruct γ as [[]|[]]; repeat sep_unfold; intuition. Qed.
Lemma perm_unlock_shared γ :
  sep_valid γ → sep_unshared (perm_unlock γ) → sep_unshared γ.
Proof. destruct γ as [[]|[]]; repeat sep_unfold; intuition. Qed.
Lemma perm_unshared γ :
  sep_valid γ → Some Locked ⊆ perm_kind γ → sep_unshared γ.
Proof. destruct (perm_kind_spec γ); repeat sep_unfold; intuition. Qed.
Lemma perm_mapped γ : Some Readable ⊆ perm_kind γ → ¬sep_unmapped γ.
Proof. destruct (perm_kind_spec γ); repeat sep_unfold; naive_solver. Qed.
Lemma perm_unmapped γ :
  sep_valid γ → perm_kind γ = Some Existing → sep_unmapped γ.
Proof. destruct (perm_kind_spec γ); repeat sep_unfold; naive_solver. Qed.
Lemma perm_None_unmapped γ : sep_valid γ → perm_kind γ = None → sep_unmapped γ.
Proof. destruct (perm_kind_spec γ); repeat sep_unfold; naive_solver. Qed.
Lemma perm_token_subseteq γ :
  sep_valid γ → Some Writable ⊆ perm_kind γ → perm_token ⊂ γ.
Proof.
  assert (∀ x', x' - 0 = 0 → x' = 0).
  { intros x'. change (x' - 0) with (x' + 0). by rewrite Qcplus_0_r. }
  rewrite strict_spec_alt. unfold perm_token.
  destruct (perm_kind_spec γ); repeat sep_unfold; (split; [|intro]);
    simplify_equality'; intuition; exfalso; auto.
Qed.
Lemma perm_splittable γ :
  sep_valid γ → Some Readable ⊆ perm_kind γ → sep_splittable γ.
Proof. destruct (perm_kind_spec γ); repeat sep_unfold; intuition. Qed.
Lemma perm_splittable_existing γ :
  sep_valid γ → perm_kind γ = Some Existing → sep_splittable γ.
Proof. by destruct (perm_kind_spec γ); repeat sep_unfold. Qed.

Lemma perm_kind_full : perm_kind perm_full = Some Writable.
Proof. done. Qed.
Lemma perm_kind_lock γ :
  Some Writable ⊆ perm_kind γ → perm_kind (perm_lock γ) = Some Locked.
Proof. by destruct (perm_kind_spec γ). Qed.
Lemma perm_kind_half γ :
  sep_valid γ → perm_kind (½ γ) =
    match perm_kind γ with
    | Some Writable => Some Readable | _ => perm_kind γ
    end.
Proof.
  assert (∀ x', x' * /2 = 0 → x' = 0).
  { intros. by apply Qcmult_integral_l with (/2); rewrite 1?Qcmult_comm. }
  assert (∀ x', x' * /2 = 1 → x' ≤ 1 → False).
  { intros x'. rewrite (Qcmult_le_mono_pos_r _ _ (/2)) by done.
    by intros -> []. }
  repeat sep_unfold; destruct (perm_kind_spec γ); unfold perm_kind; simpl;
    intros; by rewrite ?decide_False by intuition eauto.
Qed.
Lemma perm_kind_token : perm_kind perm_token = Some Existing.
Proof. done. Qed.
Lemma perm_kind_difference_token γ :
  perm_token ⊂ γ → perm_kind (γ ∖ perm_token) = perm_kind γ.
Proof.
  rewrite strict_spec_alt.
  destruct (perm_kind_spec γ) as [| |y| | |y|]; repeat sep_unfold;
    unfold perm_kind; simpl; intros [? Hneq]; auto.
  * assert (¬0 ≤ -1) by (by intros []); intuition.
  * assert (y ≤ -1 → y ≤ 0) by (by intros; transitivity (-1)).
    assert (y + 1 ≠ 0).
    { change 0 with (-1 + 1); rewrite (inj_iff (λ x, x + 1)); contradict Hneq.
      symmetry. unfold perm_token; repeat f_equal; intuition. }
    by rewrite decide_False by done.
  * by change (-0) with 0; rewrite Qcplus_0_r, !decide_False by done.
Qed.
Lemma perm_kind_subseteq γ1 γ2 : γ1 ⊆ γ2 → perm_kind γ1 ⊆ perm_kind γ2.
Proof.
  destruct γ1 as [[[x1 y1]|[x1 y1]]|x1], γ2 as [[[x2 y2]|[x2 y2]]|x2];
    unfold perm_kind; repeat sep_unfold;
    repeat case_decide; naive_solver eauto using Qcle_antisym.
Qed.
Lemma perm_lock_disjoint γ1 γ2 :
  Some Writable ⊆ perm_kind γ1 → γ1 ## γ2 → perm_lock γ1 ## γ2.
Proof.
  assert (¬2 ≤ 1) by (by intros []).
  assert (∀ x, 0 ≤ x → 1 + x ≤ 1 → x = 0).
  { intros x ? Hx. apply (Qcplus_le_mono_l x 0 1) in Hx.
    auto using Qcle_antisym. }
  destruct (perm_kind_spec γ1), γ2 as [[[x2 y2]|[x2 y2]]|];
    repeat sep_unfold; intuition; simplify_equality'; try done.
  * assert (y2 = 0) as -> by auto.
    rewrite (Qcplus_le_mono_r _ _ x2), Qcplus_0_l. eauto using Qcle_trans.
  * assert (y2 = 0) as -> by auto.
    rewrite (Qcplus_le_mono_r _ _ x2), Qcplus_0_l. eauto using Qcle_trans.
Qed.
Lemma perm_lock_union γ1 γ2 : perm_lock (γ1 ∪ γ2) = perm_lock γ1 ∪ γ2.
Proof. by destruct γ1 as [[]|], γ2 as [[]|]. Qed.
Lemma perm_unlock_disjoint γ1 γ2 : γ1 ## γ2 → perm_unlock γ1 ## γ2.
Proof. destruct γ1 as [[]|], γ2 as [[]|]; repeat sep_unfold; naive_solver. Qed.
Lemma perm_unlock_union γ1 γ2 :
  γ1 ## γ2 → perm_locked γ1 → perm_unlock (γ1 ∪ γ2) = perm_unlock γ1 ∪ γ2.
Proof. by destruct γ1 as [[]|], γ2 as [[]|]. Qed.
Lemma perm_disjoint_full γ : perm_full ## γ → γ = ∅.
Proof.
  destruct γ as [[[x y]|[x y]]|];
    repeat sep_unfold; intuition; simplify_equality'.
  assert (y = 0) as ->.
  { apply Qcle_antisym; auto. by apply (Qcplus_le_mono_l y 0 1). }
  repeat f_equal; apply Qcle_antisym; auto; rewrite <-(Qcplus_0_l x); auto.
Qed.


Require Import LibInt.
Require Import JsNumber.
Require Import String.
Require Import Store.
Require Import Monads.
Require Import Values.
Require Import Context.
Open Scope string_scope.

Implicit Type runs : Context.runs_type.
Implicit Type store : Store.store.

(****** Unary operators ******)

Definition typeof store (v : Values.value) :=
  match v with
  | Values.Undefined => Context.add_value_return store (String "undefined")
  | Values.Null => Context.add_value_return store (String  "null")
  | Values.String _ => Context.add_value_return store (String  "string")
  | Values.Number _ => Context.add_value_return store (String  "number")
  | Values.True | Values.False => Context.add_value_return store (String  "boolean")
  | Values.Object ptr =>
    assert_get_object_from_ptr store ptr (fun obj =>
      match (Values.object_code obj) with
      | Some  _ => Context.add_value_return store (String "function")
      | None => Context.add_value_return store (String  "object")
      end
    )
  | Values.Closure _ _ _ _ => (store, Fail Values.value_loc "typeof got lambda")
  end
.

Definition is_primitive store v :=
  match v with
  | Undefined | Null | String _ | Number _ | True | False =>
    Context.add_value_return store True
  | _ =>
    Context.add_value_return store False
  end
.

Definition void store (v : Values.value) :=
  Context.add_value_return store Undefined
.

Definition prim_to_str store (v : Values.value) :=
  match v with
  | Undefined => Context.add_value_return store (String "undefined")
  | Null => Context.add_value_return store (String "null")
  | String s => Context.add_value_return store (String s)
  | Number n => Context.add_value_return store (String (JsNumber.to_string n))
  | True => Context.add_value_return store (String "true")
  | False => Context.add_value_return store (String "false")
  | _ => (store, Fail Values.value_loc "prim_to_str not implemented for this type.")
  end
.

Definition prim_to_num store (v : Values.value) :=
  match v with
  | Undefined => Context.add_value_return store (Number JsNumber.nan)
  | Null => Context.add_value_return store (Number JsNumber.zero)
  | True => Context.add_value_return store (Number JsNumber.one)
  | False => Context.add_value_return store (Number JsNumber.zero)
  | Number n => Context.add_value_return store (Number n)
  | String "" => Context.add_value_return store (Number JsNumber.zero)
  | String s => Context.add_value_return store (Number (JsNumber.from_string s))
  | _ => (store, Fail value_loc "prim_to_num got invalid value.")
  end
.

Definition prim_to_bool store (v : Values.value) :=
  match v with
  | True => Context.add_value_return store True
  | False => Context.add_value_return store False
  | Undefined => Context.add_value_return store False
  | Null => Context.add_value_return store False
  | Number n => Context.add_value_return store (
      if (decide(n = JsNumber.nan)) then
        False
      else if (decide(n = JsNumber.zero)) then
        False
      else if (decide(n = JsNumber.neg_zero)) then
        False
      else
        True
    )
  | String "" => Context.add_value_return store False
  | String _ => Context.add_value_return store True
  | _ => Context.add_value_return store True
  end
.

Definition nnot store (v : Values.value) :=
  match v with
  | Undefined => Context.add_value_return store True
  | Null => Context.add_value_return store True
  | True => Context.add_value_return store False
  | False => Context.add_value_return store True
  | Number d => Context.add_value_return store (
      if (decide(d = JsNumber.zero)) then
        True
      else if (decide(d = JsNumber.neg_zero)) then
        True
      else if (decide(d <> d)) then
        True
      else
        False
    )
  | String "" => Context.add_value_return store True
  | String _ => Context.add_value_return store False
  | Object _ => Context.add_value_return store False
  | Closure _ _ _ _ => Context.add_value_return store False
  end
.

Parameter _print_string : string -> unit.
Parameter _pretty : nat -> store -> value -> unit.
Definition _seq {X Y : Type} (x : X) (y : Y) : Y :=
  y
.

Definition print store (v : Values.value) :=
  match v with
  | String s => _seq (_print_string s) (Context.add_value_return store Undefined)
  | Number n => _seq (_print_string (JsNumber.to_string n)) (Context.add_value_return store Undefined)
  | _ => (store, Fail Values.value_loc "print of non-string and non-number.")
  end
.

Definition pretty runs store v :=
  _seq
  (_pretty (Context.runs_type_nat_fuel runs) store v)
  (Context.add_value_return store Undefined)
.

Definition strlen store v :=
  match v with
  | String s => add_value_return store (Number (JsNumber.of_int (String.length s)))
  | _ => (store, Fail value_loc "strlen got non-string.")
  end
.

Definition numstr_to_num store (v : Values.value) :=
  match v with
  | String "" => Context.add_value_return store (Number JsNumber.zero)
  | String s => Context.add_value_return store (Number (JsNumber.from_string s))
  | _ => (store, Fail value_loc "numstr_to_num got invalid value.")
  end
.

Definition unary_arith store (op : number -> number) (v : Values.value) : (Store.store * Context.result Values.value_loc) :=
  match v with
  | Number n => Context.add_value_return store (Number (op n))
  | _ => (store, Fail Values.value_loc "Arithmetic with non-number.")
  end
.

Definition unary (op : string) runs store v_loc : (Store.store * (@Context.result Values.value_loc)) :=
  assert_deref store v_loc (fun v =>
    match op with
    | "print" => print store v
    | "pretty" => pretty runs store v
    | "strlen" => strlen store v
    | "typeof" => typeof store v
    | "primitive?" => is_primitive store v
    | "abs" => unary_arith store JsNumber.absolute v
    | "void" => void store v
    | "floor" => unary_arith store JsNumber.floor v
    | "prim->str" => prim_to_str store v
    | "prim->num" => prim_to_num store v
    | "prim->bool" => prim_to_bool store v
    | "!" => nnot store v
    | "numstr->num" => numstr_to_num store v
    | _ => (store, Context.Fail Values.value_loc ("Unary operator " ++ op ++ " not implemented."))
    end
  )
.

(****** Binary operators ******)

Parameter _number_eq_bool : number -> number -> bool.

Definition stx_eq store v1 v2 :=
  match (v1, v2) with
  | (String s1, String s2) => Context.add_value_return store (if (decide(s1 = s2)) then True else False)
  | (Null, Null) => Context.add_value_return store True
  | (Undefined, Undefined) => Context.add_value_return store True
  | (True, True) => Context.add_value_return store True
  | (False, False) => Context.add_value_return store True
  | (Number n1, Number n2) =>
    let (store, loc) := Store.add_bool store (_number_eq_bool n1 n2) in
    (store, Return Values.value_loc loc)
  | (Object ptr1, Object ptr2) => Context.add_value_return store (if (beq_nat ptr1 ptr2) then True else False)
  | (Closure id1 _ _ _, Closure id2 _ _ _) => Context.add_value_return store (if (beq_nat id1 id2) then True else False)
  | _ => Context.add_value_return store False
  (*| _ => Context.add_value_return store (if (beq_nat v1_loc v2_loc) then True else False)*)
  end
.

Definition has_property runs store v1_loc v2 :=
  match v2 with
  | String s =>
    let (store, res) := Context.runs_type_get_property runs store (v1_loc, s) in
    if_return store res (fun ret =>
      match ret with
      | Some _ => Context.add_value_return store True
      | None => Context.add_value_return store False
      end
    )
  | _ => (store, Fail Values.value_loc "hasProperty expected a string.")
  end
.

Definition has_own_property store v1 v2 :=
  match (v1, v2) with
  | (Object ptr, String s) =>
    assert_get_object_from_ptr store ptr (fun obj =>
      match (Values.get_object_property obj s) with
      | Some _ => Context.add_value_return store True
      | None => Context.add_value_return store False
      end
    )
  | _ => (store, Fail Values.value_loc "hasOwnProperty expected an object and a string.")
  end
.

Definition prop_to_obj store v1 v2 :=
  let make_attr := (fun x => attributes_data_of (attributes_data_intro x false false false)) in
  match (v1, v2) with
  | (Object ptr, String s) =>
    assert_get_object_from_ptr store ptr (fun obj =>
      match (Values.get_object_property obj s) with
      | Some (attributes_data_of (attributes_data_intro val writ enum config)) =>
        let (store, proto_loc) := Store.add_value store Undefined in
        let (store, config_loc) := Store.add_bool store config in
        let (store, enum_loc) := Store.add_bool store enum in
        let (store, writable_loc) := Store.add_bool store writ in
        let props := Heap.write Heap.empty "configurable" (make_attr config_loc) in
        let props := Heap.write props "enumerable" (make_attr enum_loc) in
        let props := Heap.write props "writable" (make_attr writable_loc) in
        let props := Heap.write props "value" (make_attr val) in
        let obj := object_intro proto_loc "Object" false None props None in
        let (store, loc) := Store.add_object store obj in
        (store, Return Values.value_loc loc)
      | Some (attributes_accessor_of (attributes_accessor_intro get set enum config)) =>
        let (store, proto_loc) := Store.add_value store Undefined in
        let (store, config_loc) := Store.add_bool store config in
        let (store, enum_loc) := Store.add_bool store enum in
        let props := Heap.write Heap.empty "configurable" (make_attr config_loc) in
        let props := Heap.write props "enumerable" (make_attr enum_loc) in
        let props := Heap.write props "setter" (make_attr set) in
        let props := Heap.write props "getter" (make_attr get) in
        let obj := object_intro proto_loc "Object" false None props None in
        let (store, loc) := Store.add_object store obj in
        (store, Return Values.value_loc loc)
      | None => Context.add_value_return store Undefined
      end
    )
  | _ => (store, Fail Values.value_loc "hasOwnProperty expected an object and a string.")
  end
.

Definition string_plus store v1 v2 : (Store.store * Context.result Values.value_loc) :=
  match (v1, v2) with
  | (String s1, String s2) => Context.add_value_return store (String (s1++s2))
  | _ => (store, Fail Values.value_loc "Only strings can be concatenated.")
  end
.

Parameter _nat_of_float : number -> nat.

Definition char_at store v1 v2 :=
  match (v1, v2) with
  | (Values.String s, Number n) =>
      match (String.get (_nat_of_float n) s) with
      | Some char => add_value_return store (Values.String (String.String char String.EmptyString))
      | None => (store, Fail Values.value_loc "char_at called with index larger than length.")
      end
  | _ => (store, Fail Values.value_loc "char_at called with wrong argument types.")
  end
.

Definition is_accessor runs store v1_loc v2 :=
  match v2 with
  | String s =>
    let (store, res) := Context.runs_type_get_property runs store (v1_loc, s) in
    if_return store res (fun ret =>
      match ret with
      | Some (attributes_data_of _) => Context.add_value_return store False
      | Some (attributes_accessor_of _) => Context.add_value_return store True
      | None => (store, Fail Values.value_loc "isAccessor topped out.")
      end
    )
  | _ => (store, Fail Values.value_loc "isAccessor expected an object and a string.")
  end
.

Parameter _same_value : value -> value -> bool.

Definition same_value store v1 v2 :=
  return_bool store (_same_value v1 v2)
.

Definition arith store (op : number -> number -> number) (v1 v2 : Values.value) : (Store.store * Context.result Values.value_loc) :=
  match (v1, v2) with
  | (Number n1, Number n2) => Context.add_value_return store (Number (op n1 n2))
  | _ => (store, Fail Values.value_loc "Arithmetic with non-numbers.")
  end
.

Definition cmp store undef_left undef_both undef_right (op : number -> number -> bool) (v1 v2 : Values.value) : (Store.store * Context.result Values.value_loc) :=
  match (v1, v2) with
  | (Number n1, Number n2) => Context.add_value_return store (if (op n1 n2) then True else False)
  | (Undefined, Number _) => Context.add_value_return store undef_left
  | (Undefined, Undefined) => Context.add_value_return store undef_both
  | (Number _, Undefined) => Context.add_value_return store undef_right
  | _ => (store, Fail Values.value_loc "Comparison/order of non-numbers.")
  end
.

Parameter le_bool : number -> number -> bool.
Parameter gt_bool : number -> number -> bool.
Parameter ge_bool : number -> number -> bool.

Definition binary (op : string) runs store v1_loc v2_loc : (Store.store * (Context.result Values.value_loc)) :=
  assert_deref store v1_loc (fun v1 =>
    assert_deref store v2_loc (fun v2 =>
      match op with
      | "+" => arith store JsNumber.add v1 v2
      | "-" => arith store JsNumber.sub v1 v2
      | "*" => arith store JsNumber.mult v1 v2
      | "/" => arith store JsNumber.div v1 v2
      | "%" => arith store JsNumber.fmod v1 v2
      | "<" => cmp store True False False JsNumber.lt_bool v1 v2
      | "<=" => cmp store True True False le_bool v1 v2
      | ">" => cmp store False False True gt_bool v1 v2
      | ">=" => cmp store False True True ge_bool v1 v2
      | "stx=" => stx_eq store v1 v2
      | "sameValue" => same_value store v1 v2
      | "hasProperty" => has_property runs store v1_loc v2
      | "hasOwnProperty" => has_own_property store v1 v2
      | "string+" => string_plus store v1 v2
      | "char-at" => char_at store v1 v2
      | "isAccessor" => is_accessor runs store v1_loc v2
      | "__prop->obj" => prop_to_obj store v1 v2 (* For debugging purposes *)
      | _ => (store, Context.Fail Values.value_loc ("Binary operator " ++ op ++ " not implemented."))
      end
  ))
.


Module CKTransSPL.
Require Export cktrans_spl_int.
Require Export assetmapping_spl_def.
Require Export featuremodel_spl_def.
Import FeatureModelSPL.
Import AssetMappingSPL.
Require Import Coq.Lists.ListSet.
Require Import Coq.Arith.Arith.
Require Import Coq.Init.Specif.
Require Export Coq.Lists.List.

 Inductive CK: Type.
 Parameter CKSem_func :
  CK -> AM -> Conf -> set Asset.

  (* Axiom over ck evaluation *)
  Axiom amRef_func: forall (am1 am2: AM),
    (aMR_func am1 am2) -> forall (K: CK) (C: Conf),
      wfProduct_ind (CKSem_func K am1 C) -> wfProduct_ind (CKSem_func K am2 C)
      /\ assetRef_func (CKSem_func K am1 C) (CKSem_func K am2 C).

  Parameter CKConf_func:
  CK -> set Conf.

(*  % Definition <CK equivalence>   *)
  Definition equivalentCKsAux (ck1 ck2: CK): Prop :=
   match (set_diff conf_dec (CKConf_func ck1) (CKConf_func ck2)) with
    | nil => True
    | _ => False
    end.

 Definition equivalentCKs_func (ck1 ck2: CK): Prop :=
  (equivalentCKsAux ck1 ck2) /\ (equivalentCKsAux ck2 ck1).

  Definition weakerEqCK_func (fm: FM) (ck1 ck2: CK): Prop :=
    forall am,
      forall c, set_In c (FMRef_Func fm) ->
        (CKSem_func ck1 am c = CKSem_func ck2 am c).

   Lemma equalsCK2_lemma:
  forall ck1 ck2, equivalentCKs_func ck1 ck2 -> ck1 = ck2.
    Proof.
    unfold equivalentCKs.
    unfold equivalentCKsAux. intros. destruct H.
    (*+ rewrite equalsSetDiff.
      - trivial.
      - reflexivity.
    + rewrite equalsSetDiff.
      - trivial.
      - reflexivity. *)
     Admitted.

End CKTransSPL.


(******************************************************************************)
(** * Definition of the JSMM memory model *)
(******************************************************************************)
From hahn Require Import Hahn.
Require Import Arith.
Require Import List.
Require Import Bool.
From imm Require Import Events Execution JSMM.
Require Import Execution_m.
Require Import JSMM_m.

Set Implicit Arguments.

Section JSMM_m_deadness.

Variable G : execution_m.

Variable tfree : (actid -> Prop).

Hypothesis WF_m : Wf_m G.

Notation "'E'" := G.(acts_set).
Notation "'acts'" := G.(acts).
Notation "'lab'" := G.(lab).
Notation "'range_value'" := G.(range_value).
Notation "'rf_on'" := G.(rf_on).
Notation "'overlap_on'" := G.(overlap_on).
Notation "'no_overlap'" := G.(no_overlap).
Notation "'rfb'" := G.(rfb).
Notation "'cob'" := G.(cob).
Notation "'sb'" := G.(sb).
Notation "'rf'" := G.(rf).
Notation "'co'" := G.(co).
Notation "'rmw'" := G.(rmw).
Notation "'fr'" := G.(fr).
(* Notation "'eco'" := G.(eco). *)
Notation "'same_range'" := G.(same_range).
Notation "'same_loc'" := (same_loc lab).

Notation "'R'" := (fun a => is_true (is_r lab a)).
Notation "'W'" := (fun a => is_true (is_w lab a)).
Notation "'F'" := (fun a => is_true (is_f lab a)).

Notation "'Pln'" := (fun a => is_true (is_only_pln lab a)).
Notation "'Rlx'" := (fun a => is_true (is_rlx lab a)).
Notation "'Rel'" := (fun a => is_true (is_rel lab a)).
Notation "'Acq'" := (fun a => is_true (is_acq lab a)).
Notation "'Acqrel'" := (fun a => is_true (is_acqrel lab a)).
Notation "'Acq/Rel'" := (fun a => is_true (is_ra lab a)).
Notation "'Sc'" := (fun a => is_true (is_sc lab a)).

Notation "'sw'" := G.(sw).
Notation "'hb'" := G.(hb).

Definition jsmm_m_consistent_wrong tot :=
  ⟪ Ctot   : strict_total_order E tot ⟫ /\
  ⟪ Chbtot : hb ⊆ tot ⟫ /\
  ⟪ Chbrf : irreflexive (hb ⨾ rf) ⟫ /\
  ⟪ Chbrfhb : forall n,
      irreflexive (hb ⨾ (rf_on n)⁻¹ ⨾ (hb ∩ overlap_on n) ⨾ ⦗ W ⦘) ⟫ /\
  ⟪ Cirr :
      irreflexive (⦗W⦘ ⨾ tot ⨾ sw⁻¹ ⨾ (tot ∩ same_range)) ⟫ /\
  ⟪ Ctf :
      functional (⦗tfree⦘ ⨾ (rf⁻¹ ∩ same_range) ⨾ ⦗tfree⦘) ⟫.

Record syn_dead_wrt Gtot Htot := {
  deadwrt_WRsc :
    ⦗W⦘ ⨾ Gtot ⨾ ⦗R∩₁Sc⦘ ⊆ Htot;
  deadwrt_WscW :
    ⦗W ∩₁Sc⦘ ⨾ Gtot ⨾ ⦗W⦘ ⊆ Htot;
}.

Record syn_dead Gtot := {
  deadg_hb_tot : hb ⊆ Gtot;
  deadg_tot' : forall Htot, jsmm_m_consistent_wrong Htot -> syn_dead_wrt Gtot Htot;
}.

Lemma syn_deadness_cst Gtot Htot :
  hb ⊆ Gtot ->
    strict_total_order E Gtot ->
      strict_total_order E Htot ->
        syn_dead_wrt Gtot Htot ->
          jsmm_m_consistent_wrong Htot ->
            jsmm_m_consistent_wrong Gtot.
Proof.
  intros Ha Hb Hc [Hd1 Hd2] He.
  econstructor. { assumption. }
  econstructor. { assumption. }
  econstructor. { apply He. }
  econstructor. { apply He. }
  econstructor. {
    unfold irreflexive.
    intros x H.
    destruct H as [x_ [H1 [y [H2 [z [H3 [H4 H5]]]]]]].
    destruct H1 as [H11 H12].
    rewrite <- H11 in H2.
    destruct He as [Ctot [Chbtot [Chbrf [Chbrfhb [Cirr Ctf]]]]].
    unfold irreflexive in Cirr.
    destruct Cirr with x.
    constructor 1 with x.
    split. { constructor. reflexivity. assumption. }
    constructor 1 with y.
    split. {
      apply Hd1.
      constructor 1 with x.
      split. { constructor. reflexivity. assumption. }
      constructor 1 with y.
      split. { assumption. }
      constructor. { reflexivity. }
      destruct H3 as [z_ [[H311 H312] [y_ [H32 [H33 H34]]]]].
      rewrite H33 in H32, H34.
      rewrite <- H311 in H32.
      constructor. {
      eapply rf_w_r.
      - assumption.
      - apply H32.
      }
      assumption.
    }
    constructor 1 with z.
    split. { assumption. }
    constructor. {
      apply Hd2.
      constructor 1 with z.
      destruct H3 as [z_ [[H311 H312] [y_ [H32 [H33 H34]]]]].
      rewrite H33 in H32, H34.
      rewrite <- H311 in H32.
      split. {
        constructor. { reflexivity. }
        constructor. { eapply rf_w_r. assumption. apply H32. }
        assumption.
      }
      constructor 1 with x.
      split. { assumption. }
      constructor. reflexivity. assumption.
    }
    assumption.
  }
  apply He.
Qed.

Lemma syn_deadness_sc Gtot Htot :
  hb ⊆ Gtot ->
    hb ⊆ Htot ->
      strict_total_order E Gtot ->
        strict_total_order E Htot ->
          data_race_free G ->
            syn_dead_wrt Gtot Htot ->
              seqcst G Htot ->
                seqcst G Gtot.
Proof.
  intros Ha Hb Hc Hd He [Hf1 Hf2] Hg.
  unfold seqcst.
  split.
  - unfold irreflexive.
    intros x H.
    destruct H as [y [H1 H2]].
    destruct (drf_tot__hb_sc He Hc Ha H2).
    + apply is_overlap_sym. apply rf_overlap. apply WF_m. apply H1.
    + right. eapply rf_w_r. apply WF_m. apply H1.
    + destruct Hg as [Hg1 Hg2]. apply Hg1 with x.
      constructor 1 with y.
      split. { assumption. }
      apply Hb. apply H.
    + destruct Hc as [[Hc11 Hc12] Hc2].
      apply Hc11 with x.
      apply Hc12 with y. {
        apply Ha.
        constructor. right.
        apply rf_sw.
        - apply H1.
        - apply same_range_sym. apply H.
        - apply H.
        - apply H.
      }
      apply H2.
  - intros n z H.
    destruct H as [z_ [[H11 H12] [x [[H21 H22] [y [H3 H4]]]]]].
    rewrite <- H11 in H21, H22.
    unfold transp in H3.
    assert (Htot z x) as Htot1. {
      destruct (drf_tot__hb_sc He Hc Ha H21) as [Hl | Hr].
      - eapply overlap_on_is_overlap. apply H22.
      - left. apply H12.
      - apply Hb. apply Hl.
      - apply Hf1.
        econstructor.
        split. { econstructor. reflexivity. apply H12. }
        econstructor.
        split. { apply H21. }
        econstructor. { reflexivity. }
        econstructor.
        + eapply rf_w_r. apply WF_m. eapply rf_on_rf. apply H3.
        + apply Hr.
    }
    assert (Htot y z) as Htot2. {
      destruct (drf_tot__hb_sc He Hc Ha H4) as [Hl | Hr].
      - eapply overlap_on_is_overlap. apply overlap_on_trans with x.
        apply rf_on_overlap_on. apply WF_m. apply H3. apply overlap_on_sym. apply H22.
      - left. eapply rf_w_r. apply WF_m. eapply rf_on_rf. apply H3.
      - apply Hb. apply Hl.
      - apply Hf2.
        econstructor.
        split. { econstructor. reflexivity. econstructor. eapply rf_w_r.
                 apply WF_m. eapply rf_on_rf. apply H3. apply Hr. }
        econstructor.
        split. { apply H4. }
        econstructor. { reflexivity. }
        assumption.
    }
    destruct Hg as [Hg1 Hg2].
    apply (Hg2 n z).
    econstructor.
    split. { econstructor. reflexivity. assumption. }
    econstructor.
    split. { econstructor. apply Htot1. apply H22. }
    econstructor.
    split. { apply H3. }
    apply Htot2.
Qed.

End JSMM_m_deadness.


From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Loc.
From PromisingLib Require Import Language.

Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.

Require Import PromiseConsistent.
Require Import ReorderPromises.

Set Implicit Arguments.

Definition pf_consistent lang (e:Thread.t lang): Prop :=
  forall mem1 sc1
         (CAP: Memory.cap (Thread.memory e) mem1)
         (SC_MAX: Memory.max_concrete_timemap mem1 sc1),
  exists e2,
    (<<STEPS: rtc (tau (Thread.step true)) (Thread.mk _ (Thread.state e) (Thread.local e) sc1 mem1) e2>>) /\
    ((<<FAILURE: exists e3, Thread.step true ThreadEvent.failure e2 e3 >>) \/
     (<<PROMISES: (Local.promises (Thread.local e2)) = Memory.bot>>)).

Lemma rtc_union_step_nonpf_failure
      lang e1 e2 e2'
      (STEP: rtc (union (@Thread.step lang false)) e1 e2)
      (FAILURE: Thread.step true ThreadEvent.failure e2 e2')
  :
    exists e1',
      Thread.step true ThreadEvent.failure e1 e1'.
Proof.
  ginduction STEP; eauto.
  i. exploit IHSTEP; eauto. i. des.
  exists (Thread.mk _ (Thread.state e1') (Thread.local x) (Thread.sc x) (Thread.memory x)).
  inv x0; inv STEP0. inv LOCAL. inv LOCAL0.
  inv H. inv USTEP. inv STEP0.
  econs 2; eauto. econs; eauto. econs; eauto. econs; eauto.
  ss. eapply promise_step_promise_consistent; eauto.
Qed.

Lemma consistent_pf_consistent lang (e:Thread.t lang)
      (WF: Local.wf (Thread.local e) (Thread.memory e))
      (MEM: Memory.closed (Thread.memory e))
      (CONSISTENT: Thread.consistent e)
  :
    pf_consistent e.
Proof.
  ii. exploit CONSISTENT; eauto. i. des.
  - inv FAILURE. des.
    hexploit tau_steps_pf_tau_steps; eauto; ss.
    { inv FAILURE; inv STEP. inv LOCAL. inv LOCAL0.
      hexploit rtc_tau_step_promise_consistent; eauto; ss.
      { eapply Local.cap_wf; eauto. }
      { eapply Memory.max_concrete_timemap_closed; eauto. }
      { eapply Memory.cap_closed; eauto. }
    }
    { eapply Local.cap_wf; eauto. }
    { eapply Memory.max_concrete_timemap_closed; eauto. }
    { eapply Memory.cap_closed; eauto. }
    i. des.
    exploit rtc_union_step_nonpf_failure.
    { eapply rtc_implies; [|eauto]. apply tau_union. }
    { eauto. }
    i. des.
    esplits; eauto.
  - exploit tau_steps_pf_tau_steps; eauto; ss.
    { ii. rewrite PROMISES, Memory.bot_get in *.  congr. }
    { eapply Local.cap_wf; eauto. }
    { eapply Memory.max_concrete_timemap_closed; eauto. }
    { eapply Memory.cap_closed; eauto. }
    i. des.
    exploit rtc_union_step_nonpf_bot; [|eauto|].
    { eapply rtc_implies; [|eauto]. apply tau_union. }
    i. subst. esplits; eauto.
Qed.