Require Import syntax.
Require Import alist.
Require Import Decs.

Require Import Metatheory.
Import LLVMsyntax.

Require Import sflib.

Require Import TODO.
Require Import Ords.

Set Implicit Arguments.

Local Open Scope OrdIdx_scope.

(* TODO: Move to Ords.v *)
Module Backport_Alt (E: OrdersAlt.OrderedTypeAlt) <: OrderedType.OrderedType.
  Module OT := (OrdersAlt.OT_from_Alt E).
  Include (OrdersAlt.Backport_OT OT).
End Backport_Alt.

(* TODO: move to Ords.v *)
Module prod (E1 E2: AltUsual) <: AltUsual.

  Definition t : Type := E1.t * E2.t.

  Definition compare (x y: t): comparison :=
    lexico_order [fun _ => E1.compare (fst x) (fst y) ; fun _ => E2.compare (snd x) (snd y)].

  Lemma compare_sym
        x y
    :
      <<SYM: compare y x = CompOpp (compare x y)>>
  .
  Proof.
    destruct x as [x1 x2], y as [y1 y2]. unfold compare. red.
    specialize (E1.compare_sym x1 y1). intro SYM_E1.
    specialize (E2.compare_sym x2 y2). intro SYM_E2.
    ss. des_ifs.
  Qed.

  Lemma leibniz_compare_eq1 x
    : E1.compare x x = Eq.
  Proof.
    specialize (E1.compare_sym x x). i.
    destruct (E1.compare x x) eqn:COMP; ss.
  Qed.

  Lemma leibniz_compare_eq2 x
    : E2.compare x x = Eq.
  Proof.
    specialize (E2.compare_sym x x). i.
    destruct (E2.compare x x) eqn:COMP; ss.
  Qed.

  Lemma compare_trans: forall
      c x y z (* for compatibility with Alt *)
      (XY: compare x y = c)
      (YZ: compare y z = c)
    ,
      <<XZ: compare x z = c>>
  .
  Proof.
    i. destruct x as [x1 x2], y as [y1 y2], z as [z1 z2].
    unfold compare in *. red.
    specialize (@E1.compare_trans c x1 y1 z1). intro TR_E1.
    specialize (@E2.compare_trans c x2 y2 z2). intro TR_E2.
    ss. des_ifs;
          try (by exploit TR_E1; eauto);
          try (by exploit TR_E2; eauto);
      repeat match goal with
             | [H: E1.compare ?a ?b = Eq |- _] =>
               specialize (E1.compare_leibniz H); i; []; subst; clear H
             | [H: E2.compare ?a ?b = Eq |- _] =>
               specialize (E2.compare_leibniz H); i; []; subst; clear H
             | [H: E1.compare ?a ?a = Lt |- _] =>
               rewrite leibniz_compare_eq1 in H
             | [H: E1.compare ?a ?a = Gt |- _] =>
               rewrite leibniz_compare_eq1 in H
             | [H: E2.compare ?a ?a = Lt |- _] =>
               rewrite leibniz_compare_eq2 in H
             | [H: E2.compare ?a ?a = Gt |- _] =>
               rewrite leibniz_compare_eq2 in H
      end; try congruence.
  Qed.

  Lemma compare_leibniz: forall
      x y
      (EQ: compare x y = Eq)
    ,
      x = y
  .
  Proof.
    destruct x, y; ss. unfold compare. i. ss. des_ifs.
    f_equal.
    - apply E1.compare_leibniz; ss.
    - apply E2.compare_leibniz; ss.
  Qed.

End prod.

Module Tag <: AltUsual.
  Inductive t_: Set :=
  | physical
  | previous
  | ghost
  .
  Definition t := t_.
  Definition eq := @eq t.
  Definition eq_refl := @refl_equal t.
  Definition eq_sym := @sym_eq t.
  Definition eq_trans := @trans_eq t.
  Definition eq_dec (x y:t): {x = y} + {x <> y}.
    decide equality.
  Defined.
  Global Program Instance eq_equiv : Equivalence eq.

  Definition is_previous x := match x with Tag.previous => true | _ => false end.
  Definition is_ghost x := match x with Tag.ghost => true | _ => false end.

  (* physical < previous < ghost *)
  Definition ltb (x y: t): bool :=
    match x, y with
    | physical, previous => true
    | physical, ghost => true
    | previous, ghost => true
    | _, _ => false
    end.

  (* Definition lt: t -> t -> Prop := ltb. *)

  Definition compare (x y: t): comparison :=
    if(eq_dec x y) then Eq else
      (if (ltb x y) then Lt else Gt)
  .

  Lemma compare_sym : forall x y : t, << SYM: compare y x = CompOpp (compare x y) >>.
  Proof. destruct x, y; ss. Qed.

  Lemma compare_trans :
     forall (c : comparison) (x y z : t),
       compare x y = c -> compare y z = c -> << TR:compare x z = c >>.
  Proof. i. destruct x, y, z; ss; des_ifs. Qed.

  Lemma compare_leibniz : forall x y : t, compare x y = Eq -> x = y.
  Proof. destruct x, y; ss. Qed.

End Tag.

Hint Resolve Tag.eq_dec: EqDecDb.

Module IdT <: AltUsual.
  Include (prod Tag id).

  Definition eq_dec (x y:t): {x = y} + {x <> y}.
  Proof.
    decide equality.
    apply Tag.eq_dec.
  Qed.

  Definition lift (tag:Tag.t) (i:id): t := (tag, i).

End IdT.
Hint Resolve IdT.eq_dec: EqDecDb.

Module IdTFacts := AltUsualFacts IdT.

Module IdT_OT := Backport_Alt IdT.

Module IdTSet.
  Include FSetAVLExtra IdT_OT.

  Definition clear_idt (idt0: IdT.t) (t0: t): t :=
    filter (fun x => negb (IdT.eq_dec idt0 x)) t0
  .

End IdTSet.

Module IdTSetFacts := FSetFactsExtra IdT_OT IdTSet.

(* Lemma IdT_equiv_compare_leibniz: *)
(*   forall x y, IdT.compare x y = Eq <-> x = y. *)
(* Proof. *)
(*   intros. split. *)
(*   - apply IdT.compare_leibniz. *)
(*   - i. subst. apply IdTFacts.compare_refl. *)
(* Qed. *)

Lemma InA_equiv:
  forall X (eqA eqB: X -> X -> Prop)
    (EQUIV: forall x y, eqA x y <-> eqB x y),
  forall x l, InA eqA x l <-> InA eqB x l.
Proof.
  intros.
  induction l0.
  { split; i; inv H. }
  split; i; inv H.
  - econs. apply EQUIV; auto.
  - econs 2. apply IHl0; eauto.
  - econs. apply EQUIV; auto.
  - econs 2. apply IHl0; eauto.
Qed.

Lemma IdTSet_from_list_spec ids:
  forall id, IdTSet.mem id (IdTSetFacts.from_list ids) <-> In id ids.
Proof.
  i. rewrite IdTSetFacts.from_list_spec.
  etransitivity; try apply InA_iff_In.
  apply InA_equiv. split.
  - apply IdT.compare_leibniz.
  - i. subst. apply IdTFacts.compare_refl.
Qed.

Definition bop_canTrap (b0: bop): bool :=
  match b0 with
  | bop_udiv => true
  | bop_sdiv => true
  | bop_urem => true
  | bop_srem => true
  | _ => false
  end
.

Fixpoint const_canTrap (c:const): bool :=
  match c with
  | const_arr _ cl => existsb const_canTrap cl
  | const_struct _ cl => existsb const_canTrap cl
  | const_truncop _ c1 _ => const_canTrap c1
  | const_extop _ c1 _ => const_canTrap c1
  | const_castop _ c1 _ => const_canTrap c1
  | const_gep _ c1 cl => const_canTrap c1 || existsb const_canTrap cl
  | const_select c1 c2 c3 => const_canTrap c1 || const_canTrap c2 || const_canTrap c3
  | const_icmp _ c1 c2 => const_canTrap c1 || const_canTrap c2
  | const_fcmp _ c1 c2 => const_canTrap c1 || const_canTrap c2
  | const_extractvalue c1 cl => const_canTrap c1 || existsb const_canTrap cl
  | const_insertvalue c1 c2 cl => const_canTrap c1 || const_canTrap c2 || existsb const_canTrap cl
  | const_bop b c1 c2 => const_canTrap c1 || const_canTrap c2 || bop_canTrap b
  | const_fbop _ c1 c2 => const_canTrap c1 || const_canTrap c2
  | _ => false
  end.

Module Value.
  Definition t := value.

  Definition get_ids(v: t): option id :=
    match v with
      | value_id i => Some i
      | value_const _ => None
    end.

  Definition canTrap (v: t): bool :=
    match v with
    | value_const c =>
      const_canTrap c
    | _ => false
    end
  .

End Value.

Module ValueT <: AltUsual.
  Inductive t_: Type :=
  | id (x:IdT.t)
  | const (c:const)
  .
  Definition t:= t_.
  Definition eq_dec (x y:t): {x = y} + {x <> y}.
  Proof.
    decide equality.
    apply IdT.eq_dec.
    apply const_dec.
  Qed.

  Definition case_order v : OrdIdx.t :=
    match v with
    | id _ => 0
    | const _ => 1
    end.

  Definition compare (v1 v2:t) : comparison :=
    match v1, v2 with
    | id x1, id x2 => IdT.compare x1 x2
    | const c1, const c2 => const.compare c1 c2
    | _, _ => OrdIdx.compare (case_order v1) (case_order v2)
    end.

  Lemma compare_sym
        x y
    : <<SYM: compare y x = CompOpp (compare x y)>>.
  Proof.
    destruct x, y; ss.
    - apply IdT.compare_sym.
    - apply const.compare_sym.
  Qed.

  Lemma compare_leibniz
        x y
        (EQ: compare x y = Eq)
    : x = y.
  Proof.
    destruct x, y; ss.
    - apply IdT.compare_leibniz in EQ. subst. eauto.
    - apply const.compare_leibniz in EQ. subst. eauto.
  Qed.

  (* Ltac apply_trans := *)
  (*   unfold NW in *; *)
  (*   apply_trans_base; *)
  (*   apply_trans_ typ.compare typ.compare_trans; *)
  (*   apply_trans_IH t compare'; *)
  (*   apply_trans_ (compare_list compare') *)
  (*                (@compare_list_trans'' const compare' compare_leibniz compare_refl) *)
  (* . *)

  Lemma compare_trans
        c x y z
        (XY: compare x y = c)
        (YZ: compare y z = c)
    : <<XZ: compare x z = c>>.
  Proof.
    destruct c, x, y, z; ss;
      try (by eapply IdT.compare_trans; eauto);
      try (by eapply const.compare_trans; eauto).
  Qed.

  Definition lift (tag:Tag.t) (v:value): t :=
    match v with
    | value_id i => id (IdT.lift tag i)
    | value_const c => const c
    end.

  Definition get_idTs (v: t): option IdT.t :=
    match v with
      | id i => Some i
      | const _ => None
    end.

  Definition substitute (from: IdT.t) (to: ValueT.t) (body: ValueT.t): ValueT.t :=
    match body with
    | ValueT.id i => if(IdT.eq_dec from i) then to else body
    | _ => body
    end
  .

  Definition canTrap (v: t): bool :=
    match v with
    | ValueT.const c =>
      const_canTrap c
    | _ => false
    end
  .

End ValueT.

Module ValueTFacts := AltUsualFacts ValueT.

Hint Resolve ValueT.eq_dec: EqDecDb.
Coercion ValueT.id: IdT.t >-> ValueT.t_.
Coercion ValueT.const: const >-> ValueT.t_.

Module ValueT_OT := Backport_Alt ValueT.

Module ValueTSet := FSetAVLExtra ValueT_OT.
Module ValueTSetFacts := FSetFactsExtra ValueT_OT ValueTSet.

Module ValueTPair <: AltUsual.
  Include prod ValueT ValueT.

  Definition eq_dec (x y:t): {x = y} + {x <> y}.
  Proof.
    apply prod_dec;
    apply ValueT.eq_dec.
  Defined.

  Definition get_idTs (vp: t): list IdT.t :=
    (option_to_list (ValueT.get_idTs vp.(fst)))
      ++ (option_to_list (ValueT.get_idTs vp.(snd))).

End ValueTPair.
Hint Resolve ValueTPair.eq_dec: EqDecDb.

Module ValueTPairFacts := AltUsualFacts ValueTPair. (* TODO: required? *)
Module ValueTPair_OT := Backport_Alt ValueTPair.

Module ValueTPairSet.
  Include FSetAVLExtra ValueTPair_OT.

  Definition clear_idt (idt: IdT.t) (t0: t): t :=
    filter (fun xy => negb (list_inb IdT.eq_dec (ValueTPair.get_idTs xy) idt)) t0
  .

End ValueTPairSet.

Module ValueTPairSetFacts := FSetFactsExtra ValueTPair_OT ValueTPairSet.

Module sz_ValueT := prod sz ValueT.
Module sz_ValueTFacts := AltUsualFacts sz_ValueT.

Module Expr <: AltUsual.
  Inductive t_: Type :=
  | bop (b:bop) (s:sz) (v:ValueT.t) (w:ValueT.t)
  | fbop (fb:fbop) (fp:floating_point) (v:ValueT.t) (w:ValueT.t)
  | extractvalue (t:typ) (v:ValueT.t) (lc:list const) (u:typ)
  | insertvalue (t:typ) (v:ValueT.t) (u:typ) (w:ValueT.t) (lc:list const)
  | gep (ib:inbounds) (t:typ) (v:ValueT.t) (lsv:list (sz * ValueT.t)) (u:typ)
  | trunc (top:truncop) (t:typ) (v:ValueT.t) (u:typ)
  | ext (eop:extop) (t:typ) (v:ValueT.t) (u:typ)
  | cast (cop:castop) (t:typ) (v:ValueT.t) (u:typ)
  | icmp (c:cond) (t:typ) (v:ValueT.t) (w:ValueT.t)
  | fcmp (fc:fcond) (fp:floating_point) (v:ValueT.t) (w:ValueT.t)
  | select (v:ValueT.t) (t:typ) (w:ValueT.t) (z:ValueT.t)
  | value (v:ValueT.t)
  | load (v:ValueT.t) (t:typ) (a:align)
  .

  Definition t := t_.
  Definition eq_dec (x y:t): {x = y} + {x <> y}.
  Proof.
    decide equality;
      try (apply list_eq_dec);
      try (apply prod_dec);
      try (apply IdT.eq_dec);
      try (apply ValueT.eq_dec);
      try (apply id_dec);
      try (apply Tag.eq_dec);
      try (apply sz_dec);
      try (apply bop_dec);
      try (apply fbop_dec);
      try (apply floating_point_dec);
      try (apply typ_dec);
      try (apply const_dec);
      try (apply inbounds_dec);
      try (apply truncop_dec);
      try (apply extop_dec);
      try (apply castop_dec);
      try (apply cond_dec);
      try (apply fcond_dec).
  Defined.

  Definition case_order e : OrdIdx.t :=
    match e with
    | bop _ _ _ _ => 0
    | fbop _ _ _ _ => 1
    | extractvalue _ _ _ _ => 2
    | insertvalue _ _ _ _ _ => 3
    | gep _ _ _ _ _ => 4
    | trunc _ _ _ _ => 5
    | ext _ _ _ _ => 6
    | cast _ _ _ __ => 7
    | icmp _ _ _ _ => 8
    | fcmp _ _ _ _ => 9
    | select _ _ _ _ => 10
    | value _ => 11
    | load _ _ _ => 12
    end.

  Definition compare' (e1 e2:t): comparison :=
    match e1, e2 with
    | bop b1 s1 v1 w1, bop b2 s2 v2 w2 =>
      lexico_order [fun _ => bop.compare b1 b2 ; fun _ => sz.compare s1 s2 ;
                      fun _ => ValueT.compare v1 v2 ; fun _ => ValueT.compare w1 w2]
    | fbop fb1 fp1 v1 w1, fbop fb2 fp2 v2 w2 =>
      lexico_order [fun _ => fbop.compare fb1 fb2 ; fun _ => floating_point.compare fp1 fp2 ;
                      fun _ => ValueT.compare v1 v2 ; fun _ => ValueT.compare w1 w2]
    | extractvalue t1 v1 lc1 u1, extractvalue t2 v2 lc2 u2 =>
      lexico_order [fun _ => typ.compare t1 t2 ; fun _ => ValueT.compare v1 v2 ;
                      fun _ => compare_list const.compare lc1 lc2 ;
                      fun _ => typ.compare u1 u2]
    | insertvalue t1 v1 u1 w1 lc1, insertvalue t2 v2 u2 w2 lc2 =>
      lexico_order [fun _ => typ.compare t1 t2 ; fun _ => ValueT.compare v1 v2 ;
                      fun _ => typ.compare u1 u2 ; fun _ => ValueT.compare w1 w2 ;
                        fun _ => compare_list const.compare lc1 lc2]
    | gep ib1 t1 v1 lsv1 u1, gep ib2 t2 v2 lsv2 u2 =>
      lexico_order [fun _ => bool.compare ib1 ib2 ; fun _ => typ.compare t1 t2 ;
                      fun _ => ValueT.compare v1 v2 ;
                      fun _ => compare_list sz_ValueT.compare lsv1 lsv2 ;
                      fun _ => typ.compare u1 u2]
    | trunc top1 t1 v1 u1, trunc top2 t2 v2 u2 =>
      lexico_order [fun _ => truncop.compare top1 top2 ; fun _ => typ.compare t1 t2 ;
                      fun _ => ValueT.compare v1 v2 ; fun _ => typ.compare u1 u2]
    | ext eop1 t1 v1 u1, ext eop2 t2 v2 u2 =>
      lexico_order [fun _ => extop.compare eop1 eop2 ; fun _ => typ.compare t1 t2 ;
                      fun _ => ValueT.compare v1 v2 ; fun _ => typ.compare u1 u2]
    | cast cop1 t1 v1 u1, cast cop2 t2 v2 u2 =>
      lexico_order [fun _ => castop.compare cop1 cop2 ; fun _ => typ.compare t1 t2 ;
                      fun _ => ValueT.compare v1 v2 ; fun _ => typ.compare u1 u2]
    | icmp c1 t1 v1 w1, icmp c2 t2 v2 w2 =>
      lexico_order [fun _ => cond.compare c1 c2 ; fun _ => typ.compare t1 t2 ;
                      fun _ => ValueT.compare v1 v2 ; fun _ => ValueT.compare w1 w2]
    | fcmp c1 t1 v1 w1, fcmp c2 t2 v2 w2 =>
      lexico_order [fun _ => fcond.compare c1 c2 ; fun _ => floating_point.compare t1 t2 ;
                      fun _ => ValueT.compare v1 v2 ; fun _ => ValueT.compare w1 w2]
    | select v1 t1 w1 z1, select v2 t2 w2 z2 =>
      lexico_order [fun _ => ValueT.compare v1 v2 ; fun _ => typ.compare t1 t2 ;
                      fun _ => ValueT.compare w1 w2 ; fun _ => ValueT.compare z1 z2]
    | value v1, value v2 => ValueT.compare v1 v2
    | load v1 t1 a1, load v2 t2 a2 =>
      lexico_order [fun _ => ValueT.compare v1 v2 ; fun _ => typ.compare t1 t2 ;
                      fun _ => sz.compare a1 a2]
    | _, _ => OrdIdx.compare (case_order e1) (case_order e2)
    end.

  Definition compare := wrap_compare compare'.

  Ltac comp_sym_list' cmp cmp_sym :=
      match goal with
      | [ |- context[match @compare_list ?X cmp ?a ?b with _ => _ end]] =>
        rewrite (@compare_list_sym' X b a cmp cmp_sym); destruct (compare_list cmp b a)
      end; ss.

  Ltac comp_sym_tac :=
    repeat
      (try comp_sym floating_point.compare floating_point.compare_sym;
       try comp_sym bop.compare bop.compare_sym;
       try comp_sym fbop.compare fbop.compare_sym;
       try comp_sym sz.compare sz.compare_sym;
       try comp_sym ValueT.compare ValueT.compare_sym;
       try comp_sym typ.compare typ.compare_sym;
       try comp_sym bool.compare bool.compare_sym;

       try comp_sym truncop.compare truncop.compare_sym;
       try comp_sym extop.compare extop.compare_sym;
       try comp_sym castop.compare castop.compare_sym;
       try comp_sym bop.compare bop.compare_sym;
       try comp_sym fbop.compare fbop.compare_sym;
       try comp_sym cond.compare cond.compare_sym;
       try comp_sym fcond.compare fcond.compare_sym;

       try comp_sym_list ValueT.compare ValueT.compare_sym;
       try comp_sym_list' const.compare const.compare_sym;
       try comp_sym_list' bool.compare bool.compare_sym;
       try comp_sym_list' sz_ValueT.compare sz_ValueT.compare_sym).

  Lemma compare_sym
        x y
    : <<SYM: compare y x = CompOpp (compare x y)>>.
  Proof.
    unfold compare, wrap_compare.
    destruct x, y; simpl;
      try (comp_sym_tac; congruence).
    apply ValueT.compare_sym.
  Qed.

  Corollary compare_refl z:
    compare z z = Eq.
  Proof.
    assert (compare z z = CompOpp (compare z z)).
    { apply compare_sym. }
    destruct (compare z z); ss.
  Qed.

  Ltac solve_leibniz_list' cmp cmp_l :=
    repeat match goal with
           | [H: compare_list cmp ?l1 ?l2 = Eq |- _] =>
             apply (@compare_list_leibniz _ cmp cmp_l) in H; eauto
           end; subst.

  Ltac solve_leibniz' :=
    solve_leibniz_base;
    solve_leibniz_ typ.compare typ.compare_leibniz;
    solve_leibniz_ const.compare const.compare_leibniz;
    solve_leibniz_ ValueT.compare ValueT.compare_leibniz;
    solve_leibniz_list' const.compare const.compare_leibniz;
    solve_leibniz_list' sz_ValueT.compare sz_ValueT.compare_leibniz
  .

  Ltac finish_refl :=
    unfold t, NW in *;
    finish_refl_base;
    finish_refl_ typ.compare typFacts.EOrigFacts.compare_refl;
    finish_refl_ const.compare constFacts.EOrigFacts.compare_refl;
    finish_refl_ ValueT.compare ValueTFacts.EOrigFacts.compare_refl;
    finish_refl_ compare' compare_refl;
    finish_refl_list t const const.compare const.compare_refl;
    finish_refl_list t sz_ValueT.t sz_ValueT.compare sz_ValueTFacts.EOrigFacts.compare_refl;
    try congruence
  .

  Lemma compare_leibniz
        x y
        (EQ: compare x y = Eq)
    : x = y.
  Proof.
    unfold compare, wrap_compare in *.
    destruct x; destruct y; ss;
      try by des_ifs; solve_leibniz'.
  Qed.

  Ltac solve_leibniz :=
    solve_leibniz';

    solve_leibniz_ compare' compare_leibniz;
    solve_leibniz_list' compare' compare_leibniz
  .

  Ltac apply_trans_list cmp cmp_l cmp_r cmp_t :=
    try match goal with
        | [H1: compare_list cmp ?x ?y = ?c, H2: compare_list cmp ?y ?x = ?c |- _] =>
          exploit (@compare_list_trans' _ cmp cmp_l cmp_r cmp_t c x y x); eauto; (idtac; []; i)
        end;
    try match goal with
        | [H1: compare_list cmp ?x ?y = ?c, H2: compare_list cmp ?y ?z = ?c |- _] =>
          exploit (@compare_list_trans' _ cmp cmp_l cmp_r cmp_t c x y z); eauto; (idtac; []; i)
        end.

  Ltac apply_trans :=
    unfold NW in *;
    apply_trans_base;
    apply_trans_ typ.compare typ.compare_trans;
    apply_trans_ const.compare const.compare_trans;
    apply_trans_ ValueT.compare ValueT.compare_trans;

    apply_trans_list const.compare const.compare_leibniz constFacts.EOrigFacts.compare_refl const.compare_trans;
    apply_trans_list sz_ValueT.compare sz_ValueT.compare_leibniz sz_ValueTFacts.EOrigFacts.compare_refl sz_ValueT.compare_trans
  .

  Ltac l_des_ifs :=
    clarify;
    repeat
      (match goal with
       | |- context[match ?x with _ => _ end] =>
         let H := fresh "Heq" in
         destruct x as [] eqn:H; clarify
       | H: context[ match ?x with _ => _ end ] |- _ =>
         let H := fresh "Heq" in
         destruct x as [] eqn:H; clarify
       end; try congruence).

  Lemma compare_trans
        c x y z
        (XY: compare x y = c)
        (YZ: compare y z = c)
    : <<XZ: compare x z = c>>.
  Proof.
    unfold compare, wrap_compare in *.
    Time (destruct c, x, y; try discriminate;
            destruct z; try discriminate; eauto);
      abstract (simpl in *; des_ifs; solve_leibniz; apply_trans; finish_refl). (* 142 sec*)
  Qed.

  Definition get_valueTs (e: t): list ValueT.t :=
    match e with
      | (Expr.bop _ _ v1 v2) => [v1 ; v2]
      | (Expr.fbop _ _ v1 v2) => [v1 ; v2]
      | (Expr.extractvalue _ v _ _) => [v]
      | (Expr.insertvalue _ v1 _ v2 _) => [v1 ; v2]
      | (Expr.gep _ _ v vl _) => v :: (List.map snd vl)
      | (Expr.trunc _ _ v _) => [v]
      | (Expr.ext _ _ v _) => [v]
      | (Expr.cast _ _ v _) => [v]
      | (Expr.icmp _ _ v1 v2) => [v1 ; v2]
      | (Expr.fcmp _ _ v1 v2) => [v1 ; v2]
      | (Expr.select v1 _ v2 v3) => [v1 ; v2 ; v3]
      | (Expr.value v) => [v]
      | (Expr.load v _ _) => [v]
    end.

  Definition same_modulo_value (e1 e2:Expr.t): bool :=
    match e1, e2 with
    | Expr.bop b1 s1 v1 w1, Expr.bop b2 s2 v2 w2 =>
      (bop_dec b1 b2)
        && (sz_dec s1 s2)
    | Expr.fbop fb1 fp1 v1 w1, Expr.fbop fb2 fp2 v2 w2 =>
      (fbop_dec fb1 fb2)
        && (floating_point_dec fp1 fp2)
    | Expr.extractvalue t1 v1 lc1 u1, Expr.extractvalue t2 v2 lc2 u2 =>
      (typ_dec t1 t2)
        && (list_forallb2 const_eqb lc1 lc2)
        && (typ_dec u1 u2)
    | Expr.insertvalue t1 v1 t'1 v'1 lc1, Expr.insertvalue t2 v2 t'2 v'2 lc2 =>
      (typ_dec t1 t2)
        && (typ_dec t'1 t'2)
        && (list_forallb2 const_eqb lc1 lc2)
    | Expr.gep ib1 t1 v1 lsv1 u1, Expr.gep ib2 t2 v2 lsv2 u2 =>
      (inbounds_dec ib1 ib2)
        && (typ_dec t1 t2)
        && (list_eq_dec sz_dec
                        (List.map fst lsv1)
                        (List.map fst lsv2))
        && (typ_dec u1 u2)
    | Expr.trunc top1 t1 v1 u1, Expr.trunc top2 t2 v2 u2 =>
      (truncop_dec top1 top2)
        && (typ_dec t1 t2)
        && (typ_dec u1 u2)
    | Expr.ext eop1 t1 v1 u1, Expr.ext eop2 t2 v2 u2 =>
      (extop_dec eop1 eop2)
        && (typ_dec t1 t2)
        && (typ_dec u1 u2)
    | Expr.cast cop1 t1 v1 u1, Expr.cast cop2 t2 v2 u2 =>
      (castop_dec cop1 cop2)
        && (typ_dec t1 t2)
        && (typ_dec u1 u2)
    | Expr.icmp c1 t1 v1 w1, Expr.icmp c2 t2 v2 w2  =>
      (cond_dec c1 c2)
        && (typ_dec t1 t2)
    | Expr.fcmp fc1 fp1 v1 w1, Expr.fcmp fc2 fp2 v2 w2  =>
      (fcond_dec fc1 fc2)
        && (floating_point_dec fp1 fp2)
    | Expr.select v1 t1 w1 z1, Expr.select v2 t2 w2 z2 =>
      (typ_dec t1 t2)
    | Expr.value v1, Expr.value v2 =>
      true
    | Expr.load v1 t1 a1, Expr.load v2 t2 a2 =>
      (typ_dec t1 t2)
        && (Decs.align_dec a1 a2)
    | _, _ => false
    end.

  Definition get_idTs (e: t): list IdT.t :=
    TODO.filter_map ValueT.get_idTs (get_valueTs e).

  Definition map_valueTs (e: t) (f: ValueT.t -> ValueT.t): t :=
    match e with
    | (Expr.bop _blah _blah2 v1 v2) =>
      Expr.bop _blah _blah2 (f v1) (f v2)
    | (Expr.fbop _blah _blah2 v1 v2) =>
      Expr.fbop _blah _blah2 (f v1) (f v2)
    | (Expr.extractvalue _blah v _blah2 _blah3) =>
      (Expr.extractvalue _blah (f v) _blah2 _blah3)
    | (Expr.insertvalue _blah v1 _blah2 v2 _blah3) =>
      (Expr.insertvalue _blah (f v1) _blah2 (f v2) _blah3)
    | (Expr.gep _blah _blah2 v vl _blah3) =>
      (Expr.gep _blah _blah2 (f v)
                (List.map (fun x => (fst x, (f (snd x)))) vl) _blah3)
    | (Expr.trunc _blah _blah2 v _blah3) =>
      (Expr.trunc _blah _blah2 (f v) _blah3)
    | (Expr.ext _blah _blah2 v _blah3) =>
      (Expr.ext _blah _blah2 (f v) _blah3)
    | (Expr.cast _blah _blah2 v _blah3) =>
      (Expr.cast _blah _blah2 (f v) _blah3)
    | (Expr.icmp _blah _blah2 v1 v2) =>
      (Expr.icmp _blah _blah2 (f v1) (f v2))
    | (Expr.fcmp _blah _blah2 v1 v2) =>
      (Expr.fcmp _blah _blah2 (f v1) (f v2))
    | (Expr.select v1 _blah v2 v3) =>
      (Expr.select (f v1) _blah (f v2) (f v3))
    | (Expr.value v) =>
      (Expr.value (f v))
    | (Expr.load v _blah _blah2) =>
      (Expr.load (f v) _blah _blah2)
    end.

  Definition substitute (from: IdT.t) (to: ValueT.t) (body: t): t :=
    (Expr.map_valueTs body (ValueT.substitute from to))
  .

  Definition is_load (e: t): bool :=
    match e with
    | Expr.load _ _ _ => true
    | _ => false
    end
  .

End Expr.
Hint Resolve Expr.eq_dec: EqDecDb.
Coercion Expr.value: ValueT.t >-> Expr.t_.

Module Expr_OT := Backport_Alt Expr.
Module ExprSet := FSetAVLExtra Expr_OT.

Module ExprPair <: AltUsual.
  Include prod Expr Expr.
  Definition eq_dec (x y:t): {x = y} + {x <> y}.
  Proof.
    apply prod_dec;
      apply Expr.eq_dec.
  Defined.

  Definition get_idTs (ep: t): list IdT.t :=
    (Expr.get_idTs ep.(fst))
      ++ (Expr.get_idTs ep.(snd)).
End ExprPair.

Module ExprPairFacts := AltUsualFacts ExprPair.

Module ExprPair_OT := Backport_Alt ExprPair.
Module ExprPairSet.
  Include FSetAVLExtra ExprPair_OT.

  Definition clear_idt (idt: IdT.t) (t0: t): t :=
    filter (fun xy => negb (list_inb IdT.eq_dec (ExprPair.get_idTs xy) idt)) t0
  .
End ExprPairSet.

Module ExprPairSetFacts := FSetFactsExtra ExprPair_OT ExprPairSet.

(* Ptr: alias related values *)
Module Ptr <: AltUsual.
  (* typ has the type of the 'pointer', not the type of the 'object'.
     ex: %x = load i32* %y, align 4 <- (id y, typ_pointer (typ_int 32))
                   ^^^^
  *)
  Include prod ValueT typ.

  Definition eq_dec (x y:t): {x = y} + {x <> y}.
  Proof.
    apply prod_dec.
    apply ValueT.eq_dec.
    apply typ_dec.
  Defined.

  Definition get_idTs (p: t): option IdT.t :=
    match p with
    | (v,_) => ValueT.get_idTs v
    end.

End Ptr.

Module Ptr_OT := Backport_Alt Ptr.
Module PtrSet := FSetAVLExtra Ptr_OT.
Module PtrSetFacts := FSetFactsExtra Ptr_OT PtrSet.

Lemma InA_equiv_eqs
      X (eqa eqb : X -> X -> Prop)
      (EQS_EQ: forall x y, eqa x y <-> eqb x y)
  : forall a l, InA eqa a l <-> InA eqb a l.
Proof.
  intros a l.
  induction l; split; intro HIn; inv HIn;
    try (by left; apply EQS_EQ; eauto);
    try (by right; apply IHl; eauto).
Qed.

Lemma PtrSet_from_list_spec ps:
  forall p, PtrSet.mem p (PtrSetFacts.from_list ps) <-> In p ps.
Proof.
  i. rewrite PtrSetFacts.from_list_spec.
  cut (InA (fun x y : Ptr.t => Ptr.compare x y = Eq) p ps
       <-> InA eq p ps).
  { intro EQUIV. rewrite EQUIV. apply InA_iff_In. }
  apply InA_equiv_eqs.
  i. split.
  - apply Ptr.compare_leibniz.
  - i. subst. apply PtrSet.E.eq_refl.
Qed.

Module PtrPair <: AltUsual.
  Include prod Ptr Ptr.
  Definition eq_dec (x y:t): {x = y} + {x <> y}.
  Proof.
    apply prod_dec; apply Ptr.eq_dec.
  Defined.

  Definition get_idTs (pp: t): list IdT.t :=
    (option_to_list (Ptr.get_idTs pp.(fst)))
      ++ (option_to_list (Ptr.get_idTs pp.(snd))).
End PtrPair.
Hint Resolve PtrPair.eq_dec: EqDecDb.

Module PtrPair_OT := Backport_Alt PtrPair.

Module PtrPairSet.
  Include FSetAVLExtra PtrPair_OT.
  Definition clear_idt (idt: IdT.t) (t0: t): t :=
    filter (fun xy => negb (list_inb IdT.eq_dec (PtrPair.get_idTs xy) idt)) t0
  .

End PtrPairSet.

Module PtrPairSetFacts := FSetFactsExtra PtrPair_OT PtrPairSet.

(* TODO: Remove this after migrating yoonseung's Ords.v *)
Ltac solve_leibniz_ cmp CL :=
  repeat match goal with
         | [H:cmp ?a ?b = Eq |- _] => apply CL in H
         end; subst.

Ltac solve_leibniz :=
  solve_leibniz_ IdT.compare IdT.compare_leibniz;
  solve_leibniz_ ValueT.compare ValueT.compare_leibniz;
  solve_leibniz_ Ptr.compare Ptr.compare_leibniz;
  solve_leibniz_ Expr.compare Expr.compare_leibniz;
  solve_leibniz_ ValueTPair.compare ValueTPair.compare_leibniz;
  solve_leibniz_ PtrPair.compare PtrPair.compare_leibniz;
  solve_leibniz_ ExprPair.compare ExprPair.compare_leibniz
.

Ltac solve_compat_bool := repeat red; ii; solve_leibniz; subst; eauto; ss.

Ltac finish_by_refl :=
  try apply IdTSet.E.eq_refl;
  try apply ValueTSet.E.eq_refl;
  try apply PtrSet.E.eq_refl;
  try apply ExprSet.E.eq_refl;
  try apply ValueTPairSet.E.eq_refl;
  try apply PtrPairSet.E.eq_refl;
  try apply ExprPairSet.E.eq_refl
.


Require Import prosa.model.preemption.limited_preemptive.
Require Export prosa.model.task.preemption.parameters.

(** * Task Model with Floating Non-Preemptive Regions *)

(** In this file, we instantiate the specific task model of (usually)
    preemptive tasks with "floating" non-preemptive regions, i.e., with jobs
    that exhibit non-preemptive segments of bounded length at unpredictable
    points during their execution.  *)

(** ** Model Validity *)

(** To begin with, we introduce requirements that the function
    [task_max_nonpr_segment] must satisfy to be coherent with the floating
    non-preemptive regions model. *)
Section ValidModelWithFloatingNonpreemptiveRegions.

  (** Consider any type of tasks ... *)
  Context {Task : TaskType}.
  (** ... with a bound on the maximum non-preemptive segment length ... *)
  Context `{TaskMaxNonpreemptiveSegment Task}.

  (**  ... and any type of limited-preemptive jobs associated with these tasks ... *)
  Context {Job : JobType}.
  Context `{JobTask Job Task}.
  (** ... with execution costs and specific preemption points. *)
  Context `{JobCost Job}.
  Context `{JobPreemptionPoints Job}.

  (** Consider any arrival sequence. *)
  Variable arr_seq : arrival_sequence Job.

  (** We require [task_max_nonpreemptive_segment (job_task j)] to be an upper
      bound of the length of the maximum nonpreemptive segment of job [j]. *)
  Definition job_respects_task_max_np_segment :=
    forall (j : Job),
      arrives_in arr_seq j ->
      job_max_nonpreemptive_segment j <= task_max_nonpreemptive_segment (job_task j).

  (** A model with floating nonpreemptive regions is valid if it is both valid
      a the job level and jobs respect the upper bound of their task. *)
  Definition valid_model_with_floating_nonpreemptive_regions :=
    valid_limited_preemptions_job_model arr_seq /\
    job_respects_task_max_np_segment.

End ValidModelWithFloatingNonpreemptiveRegions.

(** ** Run-to-Completion Threshold *)

(** In this section, we instantiate the task-level run-to-completion threshold
    for the model with floating non-preemptive regions. *)
Section TaskRTCThresholdFloatingNonPreemptiveRegions.

  (** Consider any type of tasks with a WCET bound.*)
  Context {Task : TaskType}.
  Context `{TaskCost Task}.

  (** In the model with floating non-preemptive regions, there is no static
      information about the placement of preemption points in all jobs, i.e.,
      it is impossible to predict when exactly a job will be preemptable. Thus,
      the only safe run-to-completion threshold is [task cost]. *)
  Global Program Instance fully_preemptive : TaskRunToCompletionThreshold Task :=
    {
      task_run_to_completion_threshold (tsk : Task) := task_cost tsk
    }.

End TaskRTCThresholdFloatingNonPreemptiveRegions.


From iris.heap_lang Require Export lifting notation.
From iris.program_logic Require Export atomic.
From iris.proofmode Require Import tactics.
From iris.heap_lang Require Import proofmode notation.
From iris.bi.lib Require Import fractional.
Set Default Proof Using "Type".

(** A general logically atomic interface for a heap. *)
Class atomic_heap {Σ} `{!heapG Σ} := AtomicHeap {
  (* -- operations -- *)
  alloc : val;
  load : val;
  store : val;
  cas : val;
  (* -- predicates -- *)
  mapsto (l : loc) (q: Qp) (v : val) : iProp Σ;
  (* -- mapsto properties -- *)
  mapsto_timeless l q v :> Timeless (mapsto l q v);
  mapsto_fractional l v :> Fractional (λ q, mapsto l q v);
  mapsto_as_fractional l q v :>
    AsFractional (mapsto l q v) (λ q, mapsto l q v) q;
  mapsto_agree l q1 q2 v1 v2 :> mapsto l q1 v1 -∗ mapsto l q2 v2 -∗ ⌜v1 = v2⌝;
  (* -- operation specs -- *)
  alloc_spec e v :
    IntoVal e v → {{{ True }}} alloc e {{{ l, RET #l; mapsto l 1 v }}};
  load_spec (l : loc) :
    <<< ∀ (v : val) q, mapsto l q v >>> load #l @ ⊤ <<< mapsto l q v, RET v >>>;
  store_spec (l : loc) (e : expr) (w : val) :
    IntoVal e w →
    <<< ∀ v, mapsto l 1 v >>> store (#l, e) @ ⊤
    <<< mapsto l 1 w, RET #() >>>;
  (* This spec is slightly weaker than it could be: It is sufficient for [w1]
  *or* [v] to be unboxed.  However, by writing it this way the [val_is_unboxed]
  is outside the atomic triple, which makes it much easier to use -- and the
  spec is still good enough for all our applications. *)
  cas_spec (l : loc) (e1 e2 : expr) (w1 w2 : val) :
    IntoVal e1 w1 → IntoVal e2 w2 → val_is_unboxed w1 →
    <<< ∀ v, mapsto l 1 v >>> cas (#l, e1, e2) @ ⊤
    <<< if decide (v = w1) then mapsto l 1 w2 else mapsto l 1 v,
        RET #(if decide (v = w1) then true else false) >>>;
}.
Arguments atomic_heap _ {_}.

(** Notation for heap primitives, in a module so you can import it separately. *)
Module notation.
Notation "l ↦{ q } v" := (mapsto l q v)
  (at level 20, q at level 50, format "l  ↦{ q }  v") : bi_scope.
Notation "l ↦ v" := (mapsto l 1 v) (at level 20) : bi_scope.

Notation "l ↦{ q } -" := (∃ v, l ↦{q} v)%I
  (at level 20, q at level 50, format "l  ↦{ q }  -") : bi_scope.
Notation "l ↦ -" := (l ↦{1} -)%I (at level 20) : bi_scope.

Notation "'ref' e" := (alloc e) : expr_scope.
Notation "! e" := (load e) : expr_scope.
Notation "e1 <- e2" := (store (e1, e2)%E) : expr_scope.

Notation CAS e1 e2 e3 := (cas (e1, e2, e3)%E).

End notation.

(** Proof that the primitive physical operations of heap_lang satisfy said interface. *)
Definition primitive_alloc : val :=
  λ: "v", ref "v".
Definition primitive_load : val :=
  λ: "l", !"l".
Definition primitive_store : val :=
  λ: "p", (Fst "p") <- (Snd "p").
Definition primitive_cas : val :=
  λ: "p", CAS (Fst (Fst "p")) (Snd (Fst "p")) (Snd "p").

Section proof.
  Context `{!heapG Σ}.

  Lemma primitive_alloc_spec e v :
    IntoVal e v → {{{ True }}} primitive_alloc e {{{ l, RET #l; l ↦ v }}}.
  Proof.
    iIntros (<- Φ) "_ HΦ". wp_let. wp_alloc l. iApply "HΦ". done.
  Qed.

  Lemma primitive_load_spec (l : loc) :
    <<< ∀ (v : val) q, l ↦{q} v >>> primitive_load #l @ ⊤
    <<< l ↦{q} v, RET v >>>.
  Proof.
    iIntros (Q Φ) "? AU". wp_let.
    iMod "AU" as (v q) "[H↦ [_ Hclose]]".
    wp_load. iMod ("Hclose" with "H↦") as "HΦ". by iApply "HΦ".
  Qed.

  Lemma primitive_store_spec (l : loc) (e : expr) (w : val) :
    IntoVal e w →
    <<< ∀ v, l ↦ v >>> primitive_store (#l, e) @ ⊤
    <<< l ↦ w, RET #() >>>.
  Proof.
    iIntros (<- Q Φ) "? AU". wp_let. wp_proj. wp_proj.
    iMod "AU" as (v) "[H↦ [_ Hclose]]".
    wp_store. iMod ("Hclose" with "H↦") as "HΦ". by iApply "HΦ".
  Qed.

  Lemma primitive_cas_spec (l : loc) e1 e2 (w1 w2 : val) :
    IntoVal e1 w1 → IntoVal e2 w2 → val_is_unboxed w1 →
    <<< ∀ (v : val), l ↦ v >>>
      primitive_cas (#l, e1, e2) @ ⊤
    <<< if decide (v = w1) then l ↦ w2 else l ↦ v,
        RET #(if decide (v = w1) then true else false) >>>.
  Proof.
    iIntros (<- <- ? Q Φ) "? AU". wp_let. repeat wp_proj.
    iMod "AU" as (v) "[H↦ [_ Hclose]]".
    destruct (decide (v = w1)) as [<-|Hv]; [wp_cas_suc|wp_cas_fail];
    iMod ("Hclose" with "H↦") as "HΦ"; by iApply "HΦ".
  Qed.
End proof.

(* NOT an instance because users should choose explicitly to use it
     (using [Explicit Instance]). *)
Definition primitive_atomic_heap `{!heapG Σ} : atomic_heap Σ :=
  {| alloc_spec := primitive_alloc_spec;
     load_spec := primitive_load_spec;
     store_spec := primitive_store_spec;
     cas_spec := primitive_cas_spec;
     mapsto_agree := gen_heap.mapsto_agree  |}.


(** Defines an RA on lists whose composition is only defined when one operand is
a prefix of the other. The result is the longer list.
In particular, the core is the identity function for all elements. *)
From iris.algebra Require Export agree list gmap updates.
From iris.algebra Require Import local_updates proofmode_classes.
From iris.prelude Require Import options.

Definition max_prefix_list (A : Type) := gmap nat (agree A).
Definition max_prefix_listR (A : ofe) := gmapUR nat (agreeR A).
Definition max_prefix_listUR (A : ofe) := gmapUR nat (agreeR A).

Definition to_max_prefix_list {A} (l : list A) : gmap nat (agree A) :=
  to_agree <$> map_seq 0 l.
Global Instance: Params (@to_max_prefix_list) 1 := {}.
Typeclasses Opaque to_max_prefix_list.

Section max_prefix_list.
  Context {A : ofe}.
  Implicit Types l : list A.

  Global Instance to_max_prefix_list_ne : NonExpansive (@to_max_prefix_list A).
  Proof. solve_proper. Qed.
  Global Instance to_max_prefix_list_proper :
    Proper ((≡) ==> (≡)) (@to_max_prefix_list A).
  Proof. solve_proper. Qed.
  Global Instance to_max_prefix_list_dist_inj n :
    Inj (dist n) (dist n) (@to_max_prefix_list A).
  Proof.
    rewrite /to_max_prefix_list. intros l1 l2 Hl. apply list_dist_lookup=> i.
    move: (Hl i). rewrite !lookup_fmap !lookup_map_seq Nat.sub_0_r.
    rewrite !option_guard_True; [|lia..].
    destruct (l1 !! i), (l2 !! i); inversion_clear 1;
      constructor; by apply (inj to_agree).
  Qed.
  Global Instance to_max_prefix_list_inj : Inj (≡) (≡) (@to_max_prefix_list A).
  Proof.
    intros l1 l2. rewrite !equiv_dist=> ? n. by apply (inj to_max_prefix_list).
  Qed.

  Global Instance mono_list_lb_core_id (m : max_prefix_list A) : CoreId m := _.

  Lemma to_max_prefix_list_valid l : ✓ to_max_prefix_list l.
  Proof.
    intros i. rewrite /to_max_prefix_list lookup_fmap.
    by destruct (map_seq 0 l !! i).
  Qed.
  Lemma to_max_prefix_list_validN n l : ✓{n} to_max_prefix_list l.
  Proof. apply cmra_valid_validN, to_max_prefix_list_valid. Qed.

  Local Lemma to_max_prefix_list_app l1 l2 :
    to_max_prefix_list (l1 ++ l2) ≡
    to_max_prefix_list l1 ⋅ (to_agree <$> map_seq (length l1) l2).
  Proof.
    rewrite /to_max_prefix_list map_seq_app=> i /=. rewrite lookup_op !lookup_fmap.
    destruct (map_seq 0 l1 !! i) as [x|] eqn:Hl1; simpl; last first.
    { by rewrite lookup_union_r // left_id. }
    rewrite (lookup_union_Some_l _ _ _ x) //=.
    assert (map_seq (M:=gmap nat A) (length l1) l2 !! i = None) as ->.
    { apply lookup_map_seq_None.
      apply lookup_map_seq_Some in Hl1 as [_ ?%lookup_lt_Some]. lia. }
    by rewrite /= right_id.
  Qed.

  Lemma to_max_prefix_list_op_l l1 l2 :
    l1 `prefix_of` l2 →
    to_max_prefix_list l1 ⋅ to_max_prefix_list l2 ≡ to_max_prefix_list l2.
  Proof. intros [l ->]. by rewrite to_max_prefix_list_app assoc -core_id_dup. Qed.
  Lemma to_max_prefix_list_op_r l1 l2 :
    l1 `prefix_of` l2 →
    to_max_prefix_list l2 ⋅ to_max_prefix_list l1 ≡ to_max_prefix_list l2.
  Proof. intros. by rewrite comm to_max_prefix_list_op_l. Qed.

  Lemma max_prefix_list_included_includedN (ml1 ml2 : max_prefix_list A) :
    ml1 ≼ ml2 ↔ ∀ n, ml1 ≼{n} ml2.
  Proof.
    split; [intros; by apply: cmra_included_includedN|].
    intros Hincl. exists ml2. apply equiv_dist=> n. destruct (Hincl n) as [l ->].
    by rewrite assoc -core_id_dup.
  Qed.

  Local Lemma to_max_prefix_list_includedN_aux n l1 l2 :
    to_max_prefix_list l1 ≼{n} to_max_prefix_list l2 →
    l2 ≡{n}≡ l1 ++ drop (length l1) l2.
  Proof.
    rewrite lookup_includedN=> Hincl. apply list_dist_lookup=> i.
    rewrite lookup_app. move: (Hincl i).
    rewrite /to_max_prefix_list !lookup_fmap !lookup_map_seq Nat.sub_0_r.
    rewrite !option_guard_True; [|lia..].
    rewrite option_includedN_total fmap_None.
    intros [Hi|(?&?&(a2&->&->)%fmap_Some&(a1&->&->)%fmap_Some&Ha)].
    - rewrite lookup_drop Hi. apply lookup_ge_None in Hi. f_equiv; lia.
    - f_equiv. symmetry. by apply to_agree_includedN.
  Qed.
  Lemma to_max_prefix_list_includedN n l1 l2 :
    to_max_prefix_list l1 ≼{n} to_max_prefix_list l2 ↔ ∃ l, l2 ≡{n}≡ l1 ++ l.
  Proof.
    split.
    - intros. eexists. by apply to_max_prefix_list_includedN_aux.
    - intros [l ->]. rewrite to_max_prefix_list_app. apply: cmra_includedN_l.
  Qed.
  Lemma to_max_prefix_list_included l1 l2 :
    to_max_prefix_list l1 ≼ to_max_prefix_list l2 ↔ ∃ l, l2 ≡ l1 ++ l.
  Proof.
    split.
    - intros. eexists. apply equiv_dist=> n.
      apply to_max_prefix_list_includedN_aux. by apply: cmra_included_includedN.
    - intros [l ->]. rewrite to_max_prefix_list_app. apply: cmra_included_l.
  Qed.
  Lemma to_max_prefix_list_included_L `{!LeibnizEquiv A} l1 l2 :
    to_max_prefix_list l1 ≼ to_max_prefix_list l2 ↔ l1 `prefix_of` l2.
  Proof. rewrite to_max_prefix_list_included /prefix. naive_solver. Qed.

  Local Lemma to_max_prefix_list_op_validN_aux n l1 l2 :
    length l1 ≤ length l2 →
    ✓{n} (to_max_prefix_list l1 ⋅ to_max_prefix_list l2) →
    l2 ≡{n}≡ l1 ++ drop (length l1) l2.
  Proof.
    intros Hlen Hvalid. apply list_dist_lookup=> i. move: (Hvalid i).
    rewrite /to_max_prefix_list lookup_op !lookup_fmap !lookup_map_seq Nat.sub_0_r.
    rewrite !option_guard_True; [|lia..].
    intros ?. rewrite lookup_app.
    destruct (l1 !! i) as [x1|] eqn:Hi1, (l2 !! i) as [x2|] eqn:Hi2; simpl in *.
    - f_equiv. symmetry. by apply to_agree_op_validN.
    - apply lookup_lt_Some in Hi1; apply lookup_ge_None in Hi2. lia.
    - apply lookup_ge_None in Hi1. rewrite lookup_drop -Hi2. f_equiv; lia.
    - apply lookup_ge_None in Hi1. rewrite lookup_drop -Hi2. f_equiv; lia.
  Qed.
  Lemma to_max_prefix_list_op_validN n l1 l2 :
    ✓{n} (to_max_prefix_list l1 ⋅ to_max_prefix_list l2) ↔
    (∃ l, l2 ≡{n}≡ l1 ++ l) ∨ (∃ l, l1 ≡{n}≡ l2 ++ l).
  Proof.
    split.
    - destruct (decide (length l1 ≤ length l2)).
      + left. eexists. by eapply to_max_prefix_list_op_validN_aux.
      + right. eexists. eapply to_max_prefix_list_op_validN_aux; [lia|by rewrite comm].
    - intros [[l ->]|[l ->]].
      + rewrite to_max_prefix_list_op_l; last by apply prefix_app_r.
        apply to_max_prefix_list_validN.
      + rewrite to_max_prefix_list_op_r; last by apply prefix_app_r.
        apply to_max_prefix_list_validN.
  Qed.
  Lemma to_max_prefix_list_op_valid l1 l2 :
    ✓ (to_max_prefix_list l1 ⋅ to_max_prefix_list l2) ↔
    (∃ l, l2 ≡ l1 ++ l) ∨ (∃ l, l1 ≡ l2 ++ l).
  Proof.
    split.
    - destruct (decide (length l1 ≤ length l2)).
      + left. eexists. apply equiv_dist=> n'.
        by eapply to_max_prefix_list_op_validN_aux, cmra_valid_validN.
      + right. eexists. apply equiv_dist=> n'.
        by eapply to_max_prefix_list_op_validN_aux,
          cmra_valid_validN; [lia|by rewrite comm].
    - intros [[l ->]|[l ->]].
      + rewrite to_max_prefix_list_op_l; last by apply prefix_app_r.
        apply to_max_prefix_list_valid.
      + rewrite to_max_prefix_list_op_r; last by apply prefix_app_r.
        apply to_max_prefix_list_valid.
  Qed.
  Lemma to_max_prefix_list_op_valid_L `{!LeibnizEquiv A} l1 l2 :
    ✓ (to_max_prefix_list l1 ⋅ to_max_prefix_list l2) ↔
    l1 `prefix_of` l2 ∨ l2 `prefix_of` l1.
  Proof. rewrite to_max_prefix_list_op_valid /prefix. naive_solver. Qed.

  Lemma max_prefix_list_local_update l1 l2 :
    l1 `prefix_of` l2 →
    (to_max_prefix_list l1, to_max_prefix_list l1) ~l~>
      (to_max_prefix_list l2, to_max_prefix_list l2).
  Proof.
    intros [l ->]. rewrite to_max_prefix_list_app (comm _ (to_max_prefix_list l1)).
    apply op_local_update=> n _. rewrite comm -to_max_prefix_list_app.
    apply to_max_prefix_list_validN.
  Qed.
End max_prefix_list.

Definition max_prefix_listURF (F : oFunctor) : urFunctor :=
  gmapURF nat (agreeRF F).

Global Instance max_prefix_listURF_contractive F :
  oFunctorContractive F → urFunctorContractive (max_prefix_listURF F).
Proof. apply _. Qed.

Definition max_prefix_listRF (F : oFunctor) : rFunctor :=
  gmapRF nat (agreeRF F).

Global Instance max_prefix_listRF_contractive F :
  oFunctorContractive F → rFunctorContractive (max_prefix_listRF F).
Proof. apply _. Qed.


Require Import AutoSep Wrap StringOps Malloc ArrayOps Buffers Bags.
Require Import SinglyLinkedList ListSegment RelDb.

Set Implicit Arguments.

Local Hint Extern 1 (@eq W _ _) => words.

(** * Inserting into a table *)

Opaque mult.
Local Infix ";;" := SimpleSeq : SP_scope.

Section Insert.
  Variable A : Type.
  Variable invPre : A -> vals -> HProp.
  Variable invPost : A -> vals -> W -> HProp.

  Variable tptr : W.
  Variable sch : schema.
  Variable bufSize : W.

  (* "WHERE" clause *)
  Variable es : list exp.

  (* Precondition and postcondition *)
  Definition invar :=
    Al a : A, Al bs,
    PRE[V] array8 bs (V "buf") * table sch tptr * mallocHeap 0
      * [| length bs = wordToNat (V "len") |] * [| inputOk V es |] * invPre a V
    POST[R] array8 bs (V "buf") * invPost a V R.

  (* Write the value of an expression into a new row's buffer. *)
  Definition writeExp (col : nat) (e : exp) : chunk :=
    match e with
      | Const s => StringWrite "ibuf" "ilen" "ipos" "overflowed" s
        (fun (p : list B * A) V => array8 (fst p) (V "buf") * mallocHeap 0 * table sch tptr
          * Ex cols, (V "row" ==*> V "ibuf", V "ilen") * array (posl cols) (V "row" ^+ $8)
          * array (lenl cols) (V "row" ^+ $8 ^+ $(length sch * 4))
          * [| length (fst p) = wordToNat (V "len") |] * [| length cols = length sch |]
          * [| V "row" <> 0 |] * [| freeable (V "row") (2 + length sch + length sch) |]
          * [| V "ibuf" <> 0 |] * [| freeable8 (V "ibuf") (wordToNat (V "ilen")) |]
          * [| inBounds (V "ilen") (firstn col cols) |] * [| inputOk V es |] * invPre (snd p) V)%Sep
        (fun _ (p : list B * A) V R => array8 (fst p) (V "buf") * invPost (snd p) V R)%Sep
      | Input start len =>
        "tmp" <- "ilen" - "ipos";;
        If ("tmp" < len) {
        "overflowed" <- 1
        } else {
          Call "array8"!"copy"("ibuf", "ipos", "buf", start, len)
          [Al a : A, Al bs, Al bsI,
            PRE[V] array8 bs (V "buf") * table sch tptr
              * [| V "ipos" <= V "ilen" |]%word
              * array8 bsI (V "ibuf") * [| length bsI = wordToNat (V "ilen") |] * [| V "ibuf" <> 0 |]
              * [| freeable8 (V "ibuf") (wordToNat (V "ilen")) |]
              * Ex cols, (V "row" ==*> V "ibuf", V "ilen") * array (posl cols) (V "row" ^+ $8)
              * array (lenl cols) (V "row" ^+ $8 ^+ $(length sch * 4))
              * [| length bs = wordToNat (V "len") |] * [| length cols = length sch |]
              * [| V "row" <> 0 |] * [| freeable (V "row") (2 + length sch + length sch) |]
              * [| V "ibuf" <> 0 |] * [| freeable8 (V "ibuf") (wordToNat (V "ilen")) |]
              * [| inBounds (V "ilen") (firstn col cols) |] * [| inputOk V es |]
              * [| V len <= V "ilen" ^- V "ipos" |]%word
              * invPre a V * mallocHeap 0
            POST[R] array8 bs (V "buf") * invPost a V R];;
          "ipos" <- "ipos" + len
        }
    end%SP.

  Definition winv' (col : nat) :=
    Al a : A, Al bs, Al bsI,
      PRE[V] array8 bs (V "buf") * table sch tptr * mallocHeap 0
        * array8 bsI (V "ibuf") * [| length bsI = wordToNat (V "ilen") |]
        * [| V "ipos" <= V "ilen" |]
        * Ex cols, (V "row" ==*> V "ibuf", V "ilen") * array (posl cols) (V "row" ^+ $8)
        * array (lenl cols) (V "row" ^+ $8 ^+ $(length sch * 4))
        * [| length bs = wordToNat (V "len") |] * [| length cols = length sch |]
        * [| V "row" <> 0 |] * [| freeable (V "row") (2 + length sch + length sch) |]
        * [| V "ibuf" <> 0 |] * [| freeable8 (V "ibuf") (wordToNat (V "ilen")) |]
        * [| inBounds (V "ilen") (firstn col cols) |] * [| inputOk V es |] * invPre a V
      POST[R] array8 bs (V "buf") * invPost a V R.

  Definition winv (col : nat) := winv' col true (fun w => w).

  Fixpoint writeExps (col : nat) (es : list exp) {struct es} : chunk :=
    match es with
      | nil => Skip
      | e :: es' =>
        (* Save the current position as the start of the current column. *)
        "tmp" <- "row" + 8;;
        "tmp" + (4 * col)%nat *<- "ipos";;

        (* Check if the current item is small enough to fit in the buffer. *)
        "tmp" <- "ilen" - "ipos";;
        If ("tmp" < lengthOf e) {
          (* It doesn't fit.  Save the "safe" length 0.  [writeExp] will set "overflowed" later. *)
          "tmp" <- "row" + 8;;
          "tmp" <- "tmp" + (length sch * 4)%nat;;
          "tmp" + (4 * col)%nat *<- 0
        } else {
          (* Good, it fits.  Save the proper length. *)
          "tmp" <- "row" + 8;;
          "tmp" <- "tmp" + (length sch * 4)%nat;;
          "tmp" + (4 * col)%nat *<- lengthOf e
        };;
        Assert [winv' (S col)];;
        writeExp (S col) e;;
        writeExps (S col) es'
    end%SP.

  Definition Insert' : chunk := (
    "ibuf" <-- Call "buffers"!"bmalloc"(bufSize)
    [Al a : A, Al bs,
      PRE[V, R] R =?>8 (wordToNat bufSize * 4) * [| R <> 0 |] * [| freeable R (wordToNat bufSize) |]
        * array8 bs (V "buf") * table sch tptr * mallocHeap 0
        * [| length bs = wordToNat (V "len") |] * [| inputOk V es |] * invPre a V
      POST[R'] array8 bs (V "buf") * invPost a V R'];;

    "row" <-- Call "malloc"!"malloc"(0, (2 + length sch + length sch)%nat)
    [Al a : A, Al bs, Al bsI,
      PRE[V, R] array8 bsI (V "ibuf") * [| length bsI = (wordToNat bufSize * 4)%nat |] * [| V "ibuf" <> 0 |]
        * [| freeable (V "ibuf") (wordToNat bufSize) |]
        * R =?> (2 + length sch + length sch)%nat * [| R <> 0 |]
        * [| freeable R (2 + length sch + length sch)%nat |]
        * array8 bs (V "buf") * table sch tptr * mallocHeap 0
        * [| length bs = wordToNat (V "len") |] * [| inputOk V es |] * invPre a V
      POST[R'] array8 bs (V "buf") * invPost a V R'];;

    "row" *<- "ibuf";;
    "ipos" <- 0;;
    "ilen" <- (4 * bufSize)%word;;
    "row"+4 *<- "ilen";;

    Note [expand_allocated 8];;

    writeExps O es;;

    "tmp" <-- Call "malloc"!"malloc"(0, 2)
    [Al a : A, Al bs,
      PRE[V, R] R =?> 2 * [| R <> 0 |] * [| freeable R 2 |]
        * row sch (V "row") * array8 bs (V "buf") * table sch tptr * mallocHeap 0
        * [| length bs = wordToNat (V "len") |] * [| inputOk V es |] * invPre a V
      POST[R'] array8 bs (V "buf") * invPost a V R'];;

    "tmp" *<- "row";;
    "tmp"+4 *<- $[tptr];;
    tptr *<- "tmp"
  )%SP.

  Section writeExps_correct.
    Variable mn : string.
    Variable im : LabelMap.t assert.
    Variable H : importsGlobal im.
    Variable ns : list string.
    Variable res : nat.

    Hypothesis not_rp : ~In "rp" ns.
    Hypothesis included : incl baseVars ns.
    Hypothesis reserved : (res >= 10)%nat.
    Hypothesis wellFormed : wfExps ns es.

    Hypothesis weakenPre : (forall a V V', (forall x, x <> "ibuf" -> x <> "row" -> x <> "ilen" -> x <> "tmp"
      -> x <> "ipos" -> x <> "overflowed" -> sel V x = sel V' x)
    -> invPre a V ===> invPre a V').

    Hypothesis weakenPost : (forall a V V' R, (forall x, x <> "ibuf" -> x <> "row" -> x <> "ilen" -> x <> "tmp"
      -> x <> "ipos" -> x <> "overflowed" -> sel V x = sel V' x)
    -> invPost a V R = invPost a V' R).

    Hypothesis copy : "array8"!"copy" ~~ im ~~> ArrayOps.copyS.

    Lemma writeExp_correct_vcs : forall e col pre,
      wfExp ns e
      -> In e es
      -> (forall specs st,
        interp specs (pre st)
        -> interp specs (winv col ns res st))
      -> vcs (VerifCond (toCmd (writeExp col e) mn (im := im) H ns res pre)).
      destruct e; wrap0.

      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
    Qed.

    Lemma writeExp_correct_post : forall e col pre,
      wfExp ns e
      -> In e es
      -> (forall specs st,
        interp specs (pre st)
        -> interp specs (winv col ns res st))
      -> forall specs st,
        interp specs (Postcondition (toCmd (writeExp col e) mn (im := im) H ns res pre) st)
        -> interp specs (winv col ns res st).
      destruct e; wrap0.

      v.
      v.
      v.
    Qed.

    Hypothesis length_es : length es = length sch.
    Hypothesis goodSize_sch : goodSize (length sch).

    Ltac split_IH := intros;
      match goal with
        | [ IH : forall pre : settings * state -> PropX _ _, _ |- _ ] =>
          generalize (fun a b c d e => proj1 (IH a b c d e));
            generalize (fun a b c d e => proj2 (IH a b c d e));
              clear IH; intros
      end;
      match goal with
        | [ H : incl (_ :: _) _ |- _ ] => apply incl_peel in H; destruct H
      end.

    Ltac basic_eauto :=
      match goal with
        | [ |- forall x, _ ] => idtac
        | [ |- Logic.ex _ ] => idtac
        | _ => simpl in *; eauto
      end.

    Lemma inBounds_move : forall ilen n m ls,
      inBounds ilen (firstn (S (n - S m)) ls)
      -> (S m <= n)%nat
      -> inBounds ilen (firstn (n - m) ls).
      intros; replace (n - m) with (S (n - S m)) by omega; auto.
    Qed.

    Hint Immediate inBounds_move.

    Lemma inBounds_wiggle : forall ilen n m col ls,
      inBounds ilen (firstn m ls)
      -> col = m - S n
      -> (S n <= m)%nat
      -> inBounds ilen (match ls with nil => nil | x :: ls' => x :: firstn (n + col) ls' end).
      intros; subst; replace m with (S (n + (m - S n))) in * |- by omega; auto.
    Qed.

    Hint Immediate inBounds_wiggle.

    Hint Rewrite Minus.le_plus_minus_r using (simpl in *; omega) : sepFormula.

    Ltac use_IH :=
      match goal with
        | [ col := ?E |- _ ] =>
          match goal with
            | [ |- appcontext[writeExps (S col)] ] =>
              change (writeExps (S col)) with (writeExps (S E))
          end; rewrite moveS by assumption;
          match goal with
            | [ H : forall x : settings * state -> PropX _ _, _ |- _ ] =>
              apply H; basic_eauto
          end

        | [ H : interp _ (Postcondition (toCmd (writeExps (S ?col) _) _ _ _ _ _) _),
            H' : forall a, wfExps _ _ -> _ |- _ ] =>
          unfold col in H; rewrite moveS in H by (simpl in *; omega);
            eapply H' in H; basic_eauto

        | _ => eapply writeExp_correct_vcs; basic_eauto
        | [ H : interp _ (Postcondition _ _) |- _ ] => eapply writeExp_correct_post in H; basic_eauto
      end; pre.

    Ltac we := repeat use_IH; t; my_descend.
    Ltac swe := solve [ we ].
    Ltac awe := abstract we.

    Lemma writeExps_correct : forall es0 pre,
      wfExps ns es0
      -> incl es0 es
      -> (length es0 <= length es)%nat
      -> let col := length es - length es0 in
        (forall specs st,
          interp specs (pre st)
          -> interp specs (winv col ns res st))
        -> vcs (VerifCond (toCmd (writeExps col es0) mn (im := im) H ns res pre))
        /\ (forall specs st,
          interp specs (Postcondition (toCmd (writeExps col es0) mn (im := im) H ns res pre) st)
          -> interp specs (winv (length es0 + col) ns res st)).
      induction es0.

      wrap0.

      split_IH.
      wrap0.
      wrap0.

      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
    Qed.
  End writeExps_correct.

  Notation InsertVcs := (fun im ns res =>
    (~In "rp" ns) :: incl baseVars ns
    :: (forall a V V', (forall x, x <> "ibuf" -> x <> "row" -> x <> "ilen" -> x <> "tmp"
      -> x <> "ipos" -> x <> "overflowed" -> sel V x = sel V' x)
      -> invPre a V ===> invPre a V')
    :: (forall a V V' R, (forall x, x <> "ibuf" -> x <> "row" -> x <> "ilen" -> x <> "tmp"
      -> x <> "ipos" -> x <> "overflowed" -> sel V x = sel V' x)
      -> invPost a V R = invPost a V' R)
    :: (res >= 10)%nat
    :: (bufSize >= natToW 2)
    :: goodSize (2 + length sch + length sch)
    :: goodSize (4 * wordToNat bufSize)
    :: wfExps ns es
    :: "buffers"!"bmalloc" ~~ im ~~> bmallocS
    :: "malloc"!"malloc" ~~ im ~~> mallocS
    :: "array8"!"copy" ~~ im ~~> ArrayOps.copyS
    :: (length es = length sch)
    :: goodSize (length sch)
    :: nil).

  Hint Immediate incl_refl.

  Require Import Div2.

  Lemma div2_double : forall n, div2 (n + n) = n.
    apply div2_double'.
  Qed.

  Hint Rewrite div2_double : sepFormula.

  Lemma four_duh : forall n,
    goodSize (4 * wordToNat bufSize)
    -> n = wordToNat bufSize * 4
    -> n = wordToNat (natToW 4 ^* bufSize).
    intros; subst.
    rewrite wordToNat_wmult.
    change (wordToNat (natToW 4)) with 4; omega.
    auto.
  Qed.

  Hint Immediate four_duh.

  Lemma inBounds_nil : forall n, inBounds n nil.
    intros; hnf; auto.
  Qed.

  Hint Immediate inBounds_nil.

  Lemma firstn_all : forall A (ls : list A) n,
    n = length ls
    -> firstn n ls = ls.
    intros; subst; induction ls; simpl; intuition.
  Qed.

  Hint Rewrite firstn_all using congruence : sepFormula.

  Ltac writeExps' :=
    try match goal with
          | [ H : ?E = _ |- match ?E with None => _ | _ => _ end ] =>
            rewrite H; post
        end;
    edestruct writeExps_correct; repeat rewrite Minus.minus_diag, Plus.plus_0_r in *;
      try match goal with
            | [ |- vcs _ ] => eauto
            | [ H : interp _ (Postcondition _ _), H' : _ |- _ ] => apply H' in H
          end; eauto; try rewrite Minus.minus_diag in *.

  Ltac writeExps :=
    match goal with
      | [ |- context[writeExps] ] => writeExps'
      | [ _ : context[writeExps] |- _ ] => writeExps'
    end.

  Lemma prove_freeable8 : forall p size,
    freeable p (wordToNat size)
    -> goodSize (4 * wordToNat size)
    -> freeable8 p (wordToNat (natToW 4 ^* size)).
    intros; rewrite wordToNat_wmult; change (wordToNat (natToW 4)) with 4; hnf; eauto.
  Qed.

  Hint Immediate prove_freeable8.

  Ltac i := abstract (try writeExps; t).

  Definition Insert : chunk.
    refine (WrapC Insert'
      invar
      invar
      InsertVcs
      _ _); abstract (wrap0; i).
  Defined.

End Insert.


Require Import Privilege.
Require Import TransitionSystems.

Require Import Ctl.BinaryRelations.
Require Import Ctl.Definition.
Require Import Glib.Glib.

Open Scope string_scope.
Open Scope env_scope.

(* value types *)

Inductive boot_token_t :=
  | good_boot_token
  | bad_boot_token.
Inductive vm_ev_t :=
  | good_vm_ev
  | bad_vm_ev.
Inductive platam_key_t :=
  | good_platam_key
  | encr_platam_key
  | bad_platam_key.
Inductive useram_key_t :=
  | good_useram_key
  | encr_useram_key
  | bad_useram_key.
Inductive useram_key_decr_key_t :=
  | good_decr_key
  | encr_decr_key
  | bad_decr_key.

(* Transition definitions *)

Inductive platam_label :=
  | platam_init
  | platam_meas_release
  | platam_listen.

(* Definition platam_state := dynamic_state platam_label. *)
Definition platam_state := platam_label × env.
Definition platam_init_state : platam_state :=
  (platam_init,
   private "platam" ? (
     "platam_key" ↦ encr_platam_key ;;
     "useram_key_decr_key" ↦ encr_decr_key
  )).

Definition decrypt_platam_key key token : platam_key_t :=
  match (key, token) with
  | (encr_platam_key, good_boot_token) => good_platam_key
  | _ => bad_platam_key
  end.

Definition decrypt_useram_key_decr_key decr_key platam_key : useram_key_decr_key_t :=
  match (decr_key, platam_key) with
  | (encr_decr_key, good_platam_key) => good_decr_key
  | _ => bad_decr_key
  end.

Inductive platam_trans : relation (platam_state × env) :=
  | platam_unlock_key : forall Γl Γl' Γg key token,
      read  Γl "platam" "platam_key" key ->
      read  Γg "platam" "boot_token" token ->
      write Γl "platam" "platam_key" (decrypt_platam_key key token) Γl' ->
      platam_trans
        (platam_init, Γl, Γg)
        (platam_meas_release, Γl', Γg)
  | platam_measure_release : forall Γl Γg Γg' platam_key decr_key,
      read  Γg "platam" "good_image" true ->
      read  Γl "platam" "useram_key_decr_key" decr_key ->
      read  Γl "platam" "platam_key" platam_key ->
      write Γg "platam" "vmm_dataport" (decrypt_useram_key_decr_key decr_key platam_key) Γg' ->
      platam_trans
        (platam_meas_release, Γl, Γg)
        (platam_listen, Γl, Γg').

(* TODO, bad_platam_trans, *)

Inductive useram_label :=
  | useram_wait_key
  | useram_listen.

Definition useram_state := useram_label × env.

Definition useram_init_state : useram_state :=
  (useram_wait_key, private "useram" ? "useram_key" ↦ encr_useram_key).

Definition decrypt_useram_key key decr_key : useram_key_t :=
  match (key, decr_key) with
  | (encr_useram_key, good_decr_key) => good_useram_key
  | _ => bad_useram_key
  end.

Inductive useram_trans : relation (useram_state × env) :=
  | useram_get_key : forall Γl Γl' Γg encr_key decr_key,
      read  Γl "useram" "useram_key" encr_key ->
      read  Γg "useram" "vmm_dataport" decr_key ->
      write Γl "useram" "useram_key" (decrypt_useram_key encr_key decr_key) Γl' ->
      useram_trans
        (useram_wait_key, Γl, Γg)
        (useram_listen, Γl', Γg).

Inductive vm_label :=
  | vm_run : useram_state -> vm_label.

Definition vm_state := vm_label.

Definition vm_init_state : vm_state := vm_run useram_init_state.

Inductive vm_trans : relation (vm_state × env) :=
  | useram_step : forall x y Γ Γ',
      useram_trans (x, Γ) (y, Γ') ->
      vm_trans (vm_run x, Γ) (vm_run y, Γ').

Inductive attarch_label :=
  | boot
  | sel4_run : platam_state -> vm_state -> attarch_label
  | attarch_bot.

Definition attarch_state := attarch_label × env.

Definition attarch_init_state : attarch_state := (boot, allReadOnly ? "good_image" ↦ true).

Inductive attarch_trans : relation attarch_state :=
  | boot_good : forall Γ,
      read Γ "root_of_trust" "good_image" true ->
      attarch_trans
        (boot, Γ)
        (sel4_run platam_init_state vm_init_state,
          allReadOnly ? "boot_token" ↦ good_boot_token;; Γ)
  | boot_bad : forall Γ,
      read Γ "root_of_trust" "good_image" false ->
      attarch_trans
        (boot, Γ)
        (sel4_run platam_init_state vm_init_state,
          allReadOnly ? "boot_token" ↦ bad_boot_token;; Γ)
  | platam_step : forall x l l' Γl Γl' Γg Γg',
      platam_trans (l, Γl, Γg) (l', Γl', Γg') ->
      attarch_trans
        (sel4_run (l, Γl) x, Γg)
        (sel4_run (l', Γl') x, Γg')
  | vm_step : forall x l l' Γg Γg',
      vm_trans (l, Γg) (l', Γg') ->
      attarch_trans
        (sel4_run x l, Γg)
        (sel4_run x l', Γg')
 | attarch_diverge : forall l Γ,
      attarch_trans (l, Γ) (attarch_bot, Γ).

Lemma attarch_trans_serial :
  serial_witness attarch_trans.
Proof using.
  unfold serial_witness.
  intros [l ?].
  eexists.
  apply attarch_diverge.
Defined.

Instance transition__attarch_trans : transition attarch_trans :=
  { trans_serial := attarch_trans_serial }.

Close Scope env_scope.
Close Scope string_scope.


(** * Bicolano: Big step (interface implementation) *)

(* <Insert License Here>

    $Id: BigStep.v 68 2006-02-02 15:06:27Z davidpichardie $ *)

(** Big step semantics.

 @author David Pichardie *)

(* Hendra : - Modified to suit DEX program.
            - Also trim the system to contain only Arithmetic *)

Require Export DEX_BigStepType.
Require Export DEX_ImplemDomain.

Open Scope type_scope.

Module DEX_BigStep <: DEX_BIGSTEP.

  Module DEX_Dom := DEX_ImplemDomain.DEX_Dom.

  (* Inductive definition are put in BigStepLoad.v.
     They are shared with BigStepType.v *)
  Load "DEX_BigStepLoad.v".

  Lemma IntraStep_ind_ :
      forall (p:DEX_Program) (P:DEX_Method->DEX_IntraNormalState->DEX_IntraNormalState+DEX_ReturnState->Prop),
         (forall m s, P m s (inl _ s)) ->
         (forall m s r, DEX_exec_return p m s r -> P m s (inr _ r)) ->
         (forall m s s' , DEX_exec_intra p m s s' ->
            forall r, DEX_IntraStepStar p m s' r -> P m s' r ->
            P m s r) ->
(* DEX Method
         (forall m s s' ret m' r,
            DEX_exec_call p m s ret m' s' (inr _ r) ->
            DEX_IntraStepStar p m' s' (inr _ ret) ->
            P m' s' (inr _ ret) ->
            P m s (inr _ r)) ->
         (forall m s s' ret m' s'' r,
            DEX_exec_call p m s ret m' s' (inl _ s'') ->
            DEX_IntraStepStar p m' s' (inr _ ret) -> P m' s' (inr _ ret) ->
            DEX_IntraStepStar p m s'' r -> P m s'' r ->
            P m s r) ->
*)
      forall m s r, DEX_IntraStep p m s r ->
        match r with
        | inr r' => P m s (inr _ r')
        | inl s' => forall r', DEX_IntraStepStar p m s' r' -> P m s' r' -> P m s r'
        end.
     Proof.
       intros p P H0 Hr Hi Hcr Hc.
       fix intra (*4*) 2;intros (*m s*) r Hs;case Hs;clear (*m s*) r Hs;intros.
       apply Hr;trivial.
       apply Hi with s2;trivial.
     Qed.
(* DEX Method
       assert (P m' s' (inr DEX_IntraNormalState ret')).
       generalize s' (inr DEX_IntraNormalState ret') H1;clear H1 H m s1 s' ret' r.
       fix fixp 3;intros s' s Ht;case Ht;clear Ht s' s;intros.
       apply H0.
       generalize (intra _ _ _ H);clear H;case r;intros.
       apply H;trivial. constructor. trivial.
       assert (HH:= intra _ _ _ H);simpl in HH.
       apply HH;trivial. apply fixp;trivial.
       generalize H;clear H;case r.
       intros s'' Hcall r' Hint HP.
       eapply Hc;eauto.
       intros r' Hcall;eapply Hcr;eauto.
     Qed.
*)

  Lemma IntraStepStar_ind :
    forall (p:DEX_Program)
     (P : DEX_Method -> DEX_IntraNormalState -> DEX_IntraNormalState + DEX_ReturnState -> Prop),
       (forall m s, P m s (inl _ s)) ->
       (forall m s r, DEX_exec_return p m s r -> P m s (inr _ r)) ->
       (forall m s s' , DEX_exec_intra p m s s' ->
          forall r, DEX_IntraStepStar p m s' r -> P m s' r ->
          P m s r) ->
(* DEX Method
       (forall m s s' ret m' r,
          DEX_exec_call p m s ret m' s' (inr _ r) ->
          DEX_IntraStepStar p m' s' (inr _ ret) ->
          P m' s' (inr _ ret) ->
          P m s (inr _ r)) ->
       (forall m s s' ret m' s'' r,
          DEX_exec_call p m s ret m' s' (inl _ s'') ->
          DEX_IntraStepStar p m' s' (inr _ ret) -> P m' s' (inr _ ret) ->
          DEX_IntraStepStar p m s'' r -> P m s'' r ->
          P m s r) ->
*)
    forall m s r, DEX_IntraStepStar p m s r -> P m s r.
   Proof.
     intros p P H0 Hr Hi (*Hcr Hc*).
     fix fixp 4; intros m s' s Ht;case Ht;clear Ht s' s;intros.
     apply H0.
     generalize (IntraStep_ind_ p P H0 Hr Hi (*Hcr Hc*) _ _ _ H).
     case r;intros;trivial.
     apply H1;trivial. constructor.
     assert (HH:=IntraStep_ind_  p P H0 Hr Hi (*Hcr Hc*) _ _ _ H);simpl in HH.
     apply HH;trivial.
     apply fixp;trivial.
   Qed.

  Lemma IntraStepStar_intra_ind :
    forall (p:DEX_Program)
     (P : DEX_Method -> DEX_IntraNormalState -> DEX_IntraNormalState -> Prop),
       (forall m s, P m s s) ->
       (forall m s s', DEX_exec_intra p m s s' ->
          forall s'', DEX_IntraStepStar_intra p m s' s'' -> P m s' s'' ->
          P m s s'') ->
(* DEX Method
       (forall m s s1 ret m' s2 s3,
          DEX_exec_call p m s ret m' s1 (inl _ s2) ->
          DEX_BigStep p m' s1 ret ->
          DEX_IntraStepStar_intra p m s2 s3 -> P m s2 s3 ->
          P m s s3) ->
*)
    forall m s s', DEX_IntraStepStar_intra p m s s' -> P m s s'.
   Proof.
     intros p P H0 Hi Hc.
     assert (forall m s r, DEX_IntraStepStar p m s r ->
              forall s', r = inl _ s' -> P m s s').
      induction 1 using IntraStepStar_ind;intros;try discriminate;subst;eauto.
      inversion H;auto.
     intros; eapply H; eauto.
   Qed.

  Lemma BigStep_ind :
    forall (p:DEX_Program)
     (P : DEX_Method -> DEX_IntraNormalState -> DEX_ReturnState -> Prop),
       (forall m s r, DEX_exec_return p m s r -> P m s r) ->
       (forall m s s' , DEX_exec_intra p m s s' ->
          forall r, DEX_BigStep p m s' r -> P m s' r ->
          P m s r) ->
(* DEX Method
       (forall m s s' ret m' r,
          DEX_exec_call p m s ret m' s' (inr _ r) ->
          DEX_BigStep p m' s' ret ->
          P m' s' ret ->
          P m s r) ->
       (forall m s s' ret m' s'' r,
          DEX_exec_call p m s ret m' s' (inl _ s'') ->
          DEX_BigStep p m' s' ret -> P m' s' ret ->
          DEX_BigStep p m s'' r -> P m s'' r ->
          P m s r) ->
*)
    forall m s r, DEX_BigStep p m s r -> P m s r.
  Proof.
   intros p P Hr Hi Hcr Hc.
   assert (forall m s R, DEX_IntraStepStar p m s R -> forall r, R = inr _ r -> P m s r).
   induction 1 using IntraStepStar_ind;intros r0 Heq;try inversion Heq;subst;
    try (eauto;fail).
   intros;eapply H;eauto.
  Qed.

  Lemma ReachableStar_ind :
    forall (p:DEX_Program)
     (P : (DEX_Method * DEX_IntraNormalState) -> (DEX_Method * DEX_IntraNormalState) -> Prop),
       (forall m s, P (m,s) (m,s)) ->
       (forall m s s', DEX_exec_intra p m s s' ->
          forall m' s'', ClosReflTrans (DEX_ReachableStep p) (m,s') (m',s'') ->
          P (m,s') (m',s'') ->
          P (m,s) (m',s'')) ->
(* DEX Method
       (forall m s s1 ret m' s2,
          DEX_exec_call p m s ret m' s1 (inl _ s2) ->
          DEX_BigStep p m' s1 ret ->
          forall m' s3, ClosReflTrans (DEX_ReachableStep p) (m,s2) (m',s3) ->
          P (m,s2) (m',s3) ->
          P (m,s) (m',s3)) ->
       (forall m pc h l m' l' bm',
        DEX_CallStep p m (pc,(h,l)) (m',l') ->
        DEX_METHOD.body m' = Some bm' ->
        forall m'' s'',
        ClosReflTrans (DEX_ReachableStep p)
          (m', (DEX_BYTECODEMETHOD.firstAddress bm',(h, l')))
          (m'',s'') ->
        P (m', (DEX_BYTECODEMETHOD.firstAddress bm',(h, l')))
          (m'',s'') ->
        P (m, (pc,(h, l))) (m'',s'')) ->
*)
    forall ms ms',
       ClosReflTrans (DEX_ReachableStep p) ms ms' -> P ms ms'.
   Proof.
     intros p P H0 Hi Hc Hsc.
     induction 1;intros.
     destruct a;eauto.
     destruct a'' as (m'',s'').
     inversion H;subst;eauto.
     inversion H2;clear H2;subst;eauto.
   Qed.

End DEX_BigStep.


From Coq Require Import
     List
     String.

From ExtLib Require Import
     Programming.Show
     Structures.Monads
     Structures.Maps.

From ITree Require Import
     ITree
     Events.State.

From Vellvm Require Import
     LLVMAst
     AstLib
     MemoryAddress
     DynamicValues
     LLVMEvents
     Local
     Error.

Set Implicit Arguments.
Set Contextual Implicit.

Import ListNotations.
Import MonadNotation.

Import ITree.Basics.Basics.Monads.

Section StackMap.
  Variable (k v:Type).
  Context {map : Type}.
  Context {M: Map k v map}.
  Context {SK : Show k}.

  Definition stack := list map.

  Definition handle_stack {E} `{FailureE -< E} : (StackE k v) ~> stateT (map * stack) (itree E) :=
      fun _ e '(env, stk) =>
        match e with
        | StackPush bs =>
          let init := List.fold_right (fun '(x,dv) => Maps.add x dv) Maps.empty bs in
          Ret ((init, env::stk), tt)
        | StackPop =>
          match stk with
          (* CB TODO: should this raise an error? Is this UB? *)
          | [] => raise "Tried to pop too many stack frames."
          | (env'::stk') => Ret ((env',stk'), tt)
          end
        end.

    (* Transform a local handler that works on maps to one that works on stacks *)
    Definition handle_local_stack {E} `{FailureE -< E} (h:(LocalE k v) ~> stateT map (itree E)) :
      LocalE k v ~> stateT (map * stack) (itree E)
      :=
      fun _ e '(env, stk) => ITree.map (fun '(env',r) => ((env',stk), r)) (h _ e env).

  Open Scope monad_scope.
  Section PARAMS.
    Variable (E F G : Type -> Type).
    Definition E_trigger {S} : forall R, E R -> (stateT S (itree (E +' F +' G)) R) :=
      fun R e m => r <- trigger e ;; ret (m, r).

    Definition F_trigger {S} : forall R, F R -> (stateT S (itree (E +' F +' G)) R) :=
      fun R e m => r <- trigger e ;; ret (m, r).

    Definition G_trigger {S} : forall R , G R -> (stateT S (itree (E +' F +' G)) R) :=
      fun R e m => r <- trigger e ;; ret (m, r).

    Definition interp_local_stack `{FailureE -< E +' F +' G}
               (h:(LocalE k v) ~> stateT map (itree _)) :
      (itree (E +' F +' ((LocalE k v) +' (StackE k v)) +' G)) ~>  stateT (map * stack) (itree (E +' F +' G)) :=
      interp_state (case_ E_trigger
                   (case_ F_trigger
                   (case_ (case_ (handle_local_stack h)
                                 handle_stack)
                          G_trigger))).
    End PARAMS.

    (* SAZ: I wasn't (yet) able to completey disentangle the ocal events from the stack events.
       This version makes the stack a kind of "wrapper" around the locals and provides a way
       of lifting locals into this new state.

       There should be some kind of lemma long the lines of:

        [forall (t:itree (E +' LocalE k v +' F) V) (env:map) (s:stack),
         run_local t env ≅
         Itree.map fst (run_local_stack (translate _into_stack t) (env, s))]

       Here, [_into_stack : (E +' LocalE k v +' F) ~> (E +' ((LocalE k v) +' StackE k v) +' F)]
       is the inclusion into stack events.
    *)

End StackMap.


(** In this file, we repackage an instance for
[compcert.backend.magree] for the concrete memory
model implemented in [compcertx.common.MemimplX].

Indeed, those two memory models are different as they use different
implementations of [inject_neutral].

Fortunately, [magree] does not use [inject_neutral], so we have nothing to prove. We just need to unpack/repack.
*)

Require compcert.backend.DeadcodeproofImpl.
Require MemimplX.

Export Deadcodeproof.
Export MemimplX.

Import Coqlib.

Lemma magree_storebytes_parallel:
   forall (m1 m2 : Memimpl.mem) (P Q : locset) (b : Values.block)
     (ofs : Z) (bytes1 : list memval) (m1' : Memimpl.mem)
     (bytes2 : list memval),
   magree m1 m2 P ->
   Mem.storebytes m1 b ofs bytes1 = Some m1' ->
   (forall (b' : Values.block) (i : Z),
    Q b' i ->
    b' <> b \/ i < ofs \/ ofs + Z.of_nat (length bytes1) <= i -> P b' i) ->
   list_forall2 memval_lessdef bytes1 bytes2 ->
   exists m2' : Memimpl.mem,
     Mem.storebytes m2 b ofs bytes2 = Some m2' /\ magree m1' m2' Q.
Proof.
  unfold Mem.storebytes.
  unfold memory_model_ops. unfold storebytes.
  intros.
  destruct (is_empty bytes1); destruct (is_empty bytes2); eauto using DeadcodeproofImpl.magree_storebytes_parallel.
  * inv H0. simpl in *.
    esplit. split. reflexivity.
    eapply DeadcodeproofImpl.magree_monotone; eauto.
    intros. destruct (zle ofs ofs0); eapply H1; eauto; intuition omega.
  * apply is_empty_list_forall2 in H2. tauto.
  * apply is_empty_list_forall2 in H2. tauto.
Qed.

Lemma magree_free:
  forall m1 m2 (P Q: locset) b lo hi m1',
  DeadcodeproofImpl.magree m1 m2 P ->
  MemimplX.free m1 b lo hi = Some m1' ->
  (forall b' i, Q b' i ->
                b' <> b \/ ~(lo <= i < hi) ->
                P b' i) ->
  exists m2', MemimplX.free m2 b lo hi = Some m2' /\ DeadcodeproofImpl.magree m1' m2' Q.
Proof.
  unfold MemimplX.free. intros.
  destruct (zle hi lo); eauto using DeadcodeproofImpl.magree_free.
  inv H0.
  esplit. split. reflexivity.
  eapply DeadcodeproofImpl.magree_monotone; eauto.
  intros. eapply H1; eauto. right. omega.
Qed.

Global Instance magree_ops
: Deadcodeproof.MAgreeOps Memimpl.mem (memory_model_ops := MemimplX.memory_model_ops)
:= {|
    magree := DeadcodeproofImpl.magree
  |}.

Global Instance magree_prf
: Deadcodeproof.MAgree Memimpl.mem (memory_model_ops := MemimplX.memory_model_ops).
Proof.
  constructor.
  exact DeadcodeproofImpl.ma_perm.
  exact DeadcodeproofImpl.magree_monotone.
  exact DeadcodeproofImpl.mextends_agree.
  exact DeadcodeproofImpl.magree_extends.
  exact DeadcodeproofImpl.magree_loadbytes.
  exact DeadcodeproofImpl.magree_load.
  exact magree_storebytes_parallel.
  exact DeadcodeproofImpl.magree_store_parallel.
  now storebytes_tac DeadcodeproofImpl.magree_storebytes_left.
  exact DeadcodeproofImpl.magree_store_left.
  exact magree_free.
Qed.


(* 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 *)