Require Import RelationClasses.

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

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

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

Require Import Cover.
Require Import MemorySplit.
Require Import MemoryMerge.
Require Import FulfillStep.

Set Implicit Arguments.

Inductive sim_message: forall (msg_src msg_tgt: Message.t), Prop :=
| sim_message_concrete
    val released_src released_tgt
    (RELEASED: View.opt_le released_src released_tgt):
    sim_message (Message.concrete val released_src) (Message.concrete val released_tgt)
| sim_message_reserve:
    sim_message Message.reserve Message.reserve
.
Hint Constructors sim_message.

Program Instance sim_message_PreOrder: PreOrder sim_message.
Next Obligation.
  ii. destruct x; econs; refl.
Qed.
Next Obligation.
  ii. inv H; inv H0; econs. etrans; eauto.
Qed.

Inductive message_same_kind: forall (msg_src msg_tgt: Message.t), Prop :=
| message_same_kind_concrete
    val_src val_tgt released_src released_tgt:
    message_same_kind (Message.concrete val_src released_src) (Message.concrete val_tgt released_tgt)
| same_message_kine_reserve:
    message_same_kind Message.reserve Message.reserve
.
Hint Constructors sim_message.

Program Instance message_same_kind_Equivalence: Equivalence message_same_kind.
Next Obligation.
  ii. destruct x; econs.
Qed.
Next Obligation.
  ii. inv H; econs.
Qed.
Next Obligation.
  ii. inv H; inv H0; econs.
Qed.

Lemma sim_message_message_same_kind
      msg_src msg_tgt
      (SIM: sim_message msg_src msg_tgt):
  message_same_kind msg_src msg_tgt.
Proof.
  inv SIM; econs.
Qed.

Inductive sim_memory (mem_src mem_tgt:Memory.t): Prop :=
| sim_memory_intro
    (COVER: forall loc ts, covered loc ts mem_src <-> covered loc ts mem_tgt)
    (MSG: forall loc from_tgt to msg_tgt
            (GET: Memory.get loc to mem_tgt = Some (from_tgt, msg_tgt)),
        exists from_src msg_src,
          <<GET: Memory.get loc to mem_src = Some (from_src, msg_src)>> /\
          <<MSG: sim_message msg_src msg_tgt>>)
    (RESERVE: forall loc from to,
        Memory.get loc to mem_src = Some (from, Message.reserve) <->
        Memory.get loc to mem_tgt = Some (from, Message.reserve))
.

Program Instance sim_memory_PreOrder: PreOrder sim_memory.
Next Obligation.
  econs; try refl. i. esplits; eauto. refl.
Qed.
Next Obligation.
  ii. inv H. inv H0. econs; try etrans; eauto. i.
  exploit MSG0; eauto. i. des.
  exploit MSG; eauto. i. des.
  esplits; eauto. etrans; eauto.
Qed.

Lemma sim_memory_get
      loc from_tgt to msg_tgt mem_src mem_tgt
      (SIM: sim_memory mem_src mem_tgt)
      (GET: Memory.get loc to mem_tgt = Some (from_tgt, msg_tgt)):
  exists from_src msg_src,
    <<GET: Memory.get loc to mem_src = Some (from_src, msg_src)>> /\
    <<MSG: sim_message msg_src msg_tgt>>.
Proof.
  eapply SIM. eauto.
Qed.

Lemma sim_memory_get_message_same_kind
      loc
      from_src to_src msg_src mem_src
      from_tgt to_tgt msg_tgt mem_tgt
      ts
      (SIM: sim_memory mem_src mem_tgt)
      (GET_SRC: Memory.get loc to_src mem_src = Some (from_src, msg_src))
      (GET_TGT: Memory.get loc to_tgt mem_tgt = Some (from_tgt, msg_tgt))
      (ITV_SRC: Interval.mem (from_src, to_src) ts)
      (ITV_TGT: Interval.mem (from_tgt, to_tgt) ts):
  message_same_kind msg_src msg_tgt.
Proof.
  destruct msg_src, msg_tgt; try by econs.
  - inv SIM. rewrite <- RESERVE in GET_TGT.
    exploit Memory.get_disjoint; [exact GET_SRC|exact GET_TGT|..]. i. des; try congr.
    exfalso. apply (x0 ts); auto.
  - inv SIM. rewrite RESERVE in GET_SRC.
    exploit Memory.get_disjoint; [exact GET_SRC|exact GET_TGT|..]. i. des; try congr.
    exfalso. apply (x0 ts); auto.
Qed.

Lemma sim_memory_get_inv
      loc from_src to_src msg_src mem_src
      mem_tgt
      (INHABITED_SRC: Memory.inhabited mem_src)
      (INHABITED_TGT: Memory.inhabited mem_tgt)
      (SIM: sim_memory mem_src mem_tgt)
      (GET_SRC: Memory.get loc to_src mem_src = Some (from_src, msg_src)):
  exists from_tgt to_tgt msg_tgt,
    <<FROM: Time.le from_tgt from_src>> /\
    <<TO: Time.le to_src to_tgt>> /\
    <<GET_TGT: Memory.get loc to_tgt mem_tgt = Some (from_tgt, msg_tgt)>> /\
    <<MSG: message_same_kind msg_src msg_tgt>>.
Proof.
  destruct (Time.eq_dec to_src Time.bot).
  { subst. rewrite INHABITED_SRC in GET_SRC. inv GET_SRC.
    esplits; try refl. apply INHABITED_TGT. }
  dup SIM. inv SIM0. dup COVER. specialize (COVER0 loc to_src). des.
  exploit COVER0.
  { econs; eauto. econs; try refl.
    exploit Memory.get_ts; eauto. i. des; subst; timetac. }
  i. dup x. inv x0. esplits; eauto.
  - destruct (Time.le_lt_dec from from_src); ss.
    dup COVER. specialize (COVER2 loc from). des. exploit COVER2.
    { econs; eauto.
      exploit Memory.get_ts; try exact GET_SRC. i. des; ss.
      inv ITV. econs; eauto. econs. ss. }
    i. inv x0.
    destruct (Time.eq_dec to0 from).
    + subst. exploit MSG; try exact GET0. i. des.
      exploit Memory.get_disjoint; [exact GET_SRC|exact GET1|..]. i. des.
      * subst. inv ITV. timetac.
      * exfalso. apply (x1 from).
        { inv ITV. econs; eauto. s. econs; eauto. }
        { econs; try refl. s.
          exploit Memory.get_ts; try exact GET1. i. des; ss.
          subst. inv ITV0. inv FROM. }
    + exploit Memory.get_disjoint; [exact GET|exact GET0|..]. i. des.
      * subst. inv ITV0. timetac.
      * exfalso. destruct (Time.le_lt_dec to to0).
        { apply (x1 to).
          - econs; try refl.
            exploit Memory.get_ts; try exact GET. i. des; ss.
            subst. inv ITV0. inv FROM.
          - econs; eauto. inv ITV0. ss.
            exploit Memory.get_ts; try exact GET. i. des; ss.
            + subst. inv l.
            + eapply TimeFacts.lt_le_lt; eauto. econs; eauto. }
        { apply (x1 to0).
          - inv ITV0. econs; ss.
            + inv TO; ss. inv H. congr.
            + econs. ss.
          - econs; try refl.
            exploit Memory.get_ts; try exact GET0. i. des; ss.
            subst. inv ITV0. ss. inv TO; inv H. inv FROM. }
  - inv ITV. ss.
  - eapply sim_memory_get_message_same_kind; eauto.
    exploit Memory.get_ts; try exact GET_SRC. i. des; try congr.
    econs; eauto. refl.
Qed.

Lemma sim_memory_max_ts
      mem_src mem_tgt loc
      (SIM: sim_memory mem_src mem_tgt)
      (CLOSED_SRC: Memory.closed mem_src)
      (CLOSED_TGT: Memory.closed mem_tgt):
  Memory.max_ts loc mem_src = Memory.max_ts loc mem_tgt.
Proof.
  inv SIM. inv CLOSED_SRC. inv CLOSED_TGT.
  clear MSG RESERVE CLOSED CLOSED0.
  apply TimeFacts.antisym.
  - specialize (COVER loc (Memory.max_ts loc mem_src)). des.
    exploit Memory.max_ts_spec; try eapply (INHABITED loc). i. des.
    exploit Memory.get_ts; eauto. i. des.
    { rewrite x1. apply Time.bot_spec. }
    exploit COVER; i.
    { econs; eauto. econs; eauto. refl. }
    inv x. exploit Memory.max_ts_spec; try exact GET0. i. des.
    inv ITV. ss. etrans; eauto.
  - specialize (COVER loc (Memory.max_ts loc mem_tgt)). des.
    exploit Memory.max_ts_spec; try eapply (INHABITED0 loc). i. des.
    exploit Memory.get_ts; eauto. i. des.
    { rewrite x1. apply Time.bot_spec. }
    exploit COVER0; i.
    { econs; eauto. econs; eauto. refl. }
    inv x. exploit Memory.max_ts_spec; try exact GET0. i. des.
    inv ITV. ss. etrans; eauto.
Qed.

Lemma sim_memory_max_concrete_ts
      mem_src mem_tgt
      loc mts_src mts_tgt
      (SIM: sim_memory mem_src mem_tgt)
      (CLOSED_SRC: Memory.closed mem_src)
      (CLOSED_TGT: Memory.closed mem_tgt)
      (MAX_SRC: Memory.max_concrete_ts mem_src loc mts_src)
      (MAX_TGT: Memory.max_concrete_ts mem_tgt loc mts_tgt):
  mts_src = mts_tgt.
Proof.
  apply TimeFacts.antisym.
  - inv MAX_SRC. des.
    exploit sim_memory_get_inv; eauto.
    { apply CLOSED_SRC. }
    { apply CLOSED_TGT. }
    i. des. inv MSG.
    exploit Memory.max_concrete_ts_spec; eauto. i. des.
    etrans; eauto.
  - inv MAX_TGT. des.
    inv SIM. exploit MSG; eauto. i. des. inv MSG0.
    exploit Memory.max_concrete_ts_spec; eauto. i. des. ss.
Qed.

Lemma sim_memory_max_concrete_timemap
      mem_src mem_tgt mtm_src mtm_tgt
      (CLOSED_SRC: Memory.closed mem_src)
      (CLOSED_TGT: Memory.closed mem_tgt)
      (SIM: sim_memory mem_src mem_tgt)
      (MAX_SRC: Memory.max_concrete_timemap mem_src mtm_src)
      (MAX_TGT: Memory.max_concrete_timemap mem_tgt mtm_tgt):
  mtm_src = mtm_tgt.
Proof.
  extensionality loc.
  specialize (MAX_SRC loc).
  specialize (MAX_TGT loc).
  eapply sim_memory_max_concrete_ts; eauto.
Qed.

Lemma sim_memory_max_concrete_view
      mem_src mem_tgt mview_src mview_tgt
      (CLOSED_SRC: Memory.closed mem_src)
      (CLOSED_TGT: Memory.closed mem_tgt)
      (SIM: sim_memory mem_src mem_tgt)
      (MAX_SRC: Memory.max_concrete_view mem_src mview_src)
      (MAX_TGT: Memory.max_concrete_view mem_tgt mview_tgt):
  mview_src = mview_tgt.
Proof.
  inv MAX_SRC. inv MAX_TGT.
  exploit sim_memory_max_concrete_timemap; try exact SIM; eauto. i.
  subst. ss.
Qed.

Lemma split_sim_memory
      mem0 loc ts1 ts2 ts3 val2 released2 val3 released3 mem1
      (SPLIT: Memory.split mem0 loc ts1 ts2 ts3 (Message.concrete val2 released2) (Message.concrete val3 released3) mem1):
  sim_memory mem1 mem0.
Proof.
  econs; i.
  - eapply split_covered. eauto.
  - exploit Memory.split_get0; eauto. i. des.
    erewrite Memory.split_o; eauto. repeat condtac; ss.
    + des. subst. congr.
    + guardH o. des. subst. rewrite GET1 in GET. inv GET.
      esplits; eauto. refl.
    + esplits; eauto. refl.
  - exploit Memory.split_get0; eauto. i. des.
    erewrite Memory.split_o; eauto.
    repeat condtac; ss; split; i; try congr.
    + des. subst. rewrite GET in H. inv H.
    + guardH o. des. subst. rewrite GET0 in H. inv H.
Qed.

Lemma lower_sim_memory
      mem1 loc from to msg1 msg2 mem2
      (LOWER: Memory.lower mem1 loc from to msg1 msg2 mem2)
      (MSG: message_same_kind msg1 msg2):
  sim_memory mem2 mem1.
Proof.
  econs; i.
  - eapply lower_covered. eauto.
  - i. erewrite Memory.lower_o; eauto. condtac; ss.
    + des. subst.
      exploit Memory.lower_get0; eauto. i. des.
      rewrite GET0 in GET. inv GET.
      inv MSG_LE; inv MSG; esplits; eauto.
    + esplits; eauto. refl.
  - split; i.
    + revert H. erewrite Memory.lower_o; eauto. condtac; ss.
      i. des. subst. inv H. inv LOWER. inv LOWER0. inv MSG.
      unfold Memory.get, Cell.get. rewrite GET2. ss.
    + erewrite Memory.lower_o; eauto. condtac; ss.
      des. subst. inv LOWER. inv LOWER0.
      unfold Memory.get, Cell.get in H. rewrite H in GET2. inv GET2.
      inv MSG. ss.
Qed.

Lemma promise_lower_sim_memory
      promises1 mem1 loc from to msg1 msg2 promises2 mem2
      (PROMISE: Memory.promise promises1 mem1 loc from to msg2 promises2 mem2 (Memory.op_kind_lower msg1))
      (MSG: message_same_kind msg1 msg2):
  sim_memory mem2 mem1.
Proof.
  inv PROMISE. eapply lower_sim_memory; eauto.
Qed.

Lemma sim_memory_add
      mem1_src mem1_tgt msg_src
      mem2_src mem2_tgt msg_tgt
      loc from to
      (SIM_MSG: sim_message msg_src msg_tgt)
      (SRC: Memory.add mem1_src loc from to msg_src mem2_src)
      (TGT: Memory.add mem1_tgt loc from to msg_tgt mem2_tgt)
      (SIM: sim_memory mem1_src mem1_tgt):
  sim_memory mem2_src mem2_tgt.
Proof.
  inv SIM. econs; i.
  - rewrite add_covered; [|eauto]. rewrite (@add_covered mem2_tgt); [|eauto].
    econs; i; des; (try by right).
    + left. eapply COVER. eauto.
    + left. eapply COVER. eauto.
  - revert GET. erewrite Memory.add_o; eauto. condtac; ss.
    + des. subst. i. inv GET. esplits; eauto.
      erewrite Memory.add_o; eauto. condtac; ss.
    + erewrite (@Memory.add_o mem2_src); eauto. condtac; ss. eauto.
  - split; i.
    + erewrite Memory.add_o in H; try exact SRC.
      erewrite Memory.add_o; try exact TGT. condtac; ss.
      * des. subst. inv H. inv SIM_MSG. ss.
      * rewrite <- RESERVE. ss.
    + erewrite Memory.add_o in H; try exact TGT.
      erewrite Memory.add_o; try exact SRC. condtac; ss.
      * des. subst. inv H. inv SIM_MSG. ss.
      * rewrite RESERVE. ss.
Qed.

Lemma sim_memory_split
      mem1_src mem1_tgt
      mem2_src mem2_tgt
      loc ts1 ts2 ts3 msg2_src msg3_src msg2_tgt msg3_tgt
      (SIM_MSG: sim_message msg2_src msg2_tgt)
      (SRC: Memory.split mem1_src loc ts1 ts2 ts3 msg2_src msg3_src mem2_src)
      (TGT: Memory.split mem1_tgt loc ts1 ts2 ts3 msg2_tgt msg3_tgt mem2_tgt)
      (SIM: sim_memory mem1_src mem1_tgt):
  sim_memory mem2_src mem2_tgt.
Proof.
  inv SIM. econs; i.
  - rewrite split_covered; [|eauto]. rewrite (@split_covered mem2_tgt); [|eauto].
    apply COVER.
  - revert GET. erewrite Memory.split_o; eauto. repeat condtac; ss.
    + des. subst. i. inv GET. esplits; eauto.
      erewrite Memory.split_o; eauto. condtac; ss.
    + erewrite (@Memory.split_o mem2_src); eauto. repeat condtac; ss.
      i. inv GET. guardH o. guardH o0. des. subst.
      exploit Memory.split_get0; try exact SRC; eauto. i. des.
      exploit Memory.split_get0; try exact TGT; eauto. i. des.
      exploit MSG; eauto. i. des. rewrite GET0 in GET7. inv GET7.
      esplits; eauto.
    + erewrite (@Memory.split_o mem2_src); eauto. repeat condtac; ss. eauto.
  - split; i.
    + erewrite Memory.split_o in H; try exact SRC.
      erewrite Memory.split_o; try exact TGT. repeat condtac; ss.
      * des. subst. inv H. inv SIM_MSG. ss.
      * guardH o. des. subst. inv H.
        exploit Memory.split_get0; try exact SRC. i. des.
        exploit Memory.split_get0; try exact TGT. i. des.
        rewrite RESERVE in GET0. rewrite GET0 in GET4. inv GET4. ss.
      * rewrite <- RESERVE. ss.
    + erewrite Memory.split_o in H; try exact TGT.
      erewrite Memory.split_o; try exact SRC. repeat condtac; ss.
      * des. subst. inv H. inv SIM_MSG. ss.
      * guardH o. des. subst. inv H.
        exploit Memory.split_get0; try exact SRC. i. des.
        exploit Memory.split_get0; try exact TGT. i. des.
        rewrite <- RESERVE in GET4. rewrite GET0 in GET4. inv GET4. ss.
      * rewrite RESERVE. ss.
Qed.

Lemma sim_memory_lower
      mem1_src mem1_tgt
      mem2_src mem2_tgt
      loc from to msg1_src msg2_src msg1_tgt msg2_tgt
      (SIM_MSG: sim_message msg2_src msg2_tgt)
      (SRC: Memory.lower mem1_src loc from to msg1_src msg2_src mem2_src)
      (TGT: Memory.lower mem1_tgt loc from to msg1_tgt msg2_tgt mem2_tgt)
      (SIM: sim_memory mem1_src mem1_tgt):
  sim_memory mem2_src mem2_tgt.
Proof.
  dup SIM. inv SIM0. econs; i.
  - rewrite lower_covered; [|eauto]. rewrite (@lower_covered mem2_tgt); [|eauto].
    apply COVER.
  - revert GET. erewrite Memory.lower_o; eauto. condtac; ss.
    + des. subst. i. inv GET. esplits; eauto.
      erewrite Memory.lower_o; eauto. condtac; ss.
    + erewrite (@Memory.lower_o mem2_src); eauto. condtac; ss. eauto.
  - split; i.
    + erewrite Memory.lower_o in H; try exact SRC.
      erewrite Memory.lower_o; try exact TGT. condtac; ss.
      * des. subst. inv H. inv SIM_MSG. ss.
      * rewrite <- RESERVE. ss.
    + erewrite Memory.lower_o in H; try exact TGT.
      erewrite Memory.lower_o; try exact SRC. condtac; ss.
      * des. subst. inv H. inv SIM_MSG. ss.
      * rewrite RESERVE. ss.
Qed.

Lemma sim_memory_remove
      mem1_src mem1_tgt
      mem2_src mem2_tgt
      loc from to msg_src msg_tgt
      (SRC: Memory.remove mem1_src loc from to msg_src mem2_src)
      (TGT: Memory.remove mem1_tgt loc from to msg_tgt mem2_tgt)
      (SIM: sim_memory mem1_src mem1_tgt):
  sim_memory mem2_src mem2_tgt.
Proof.
  dup SIM. inv SIM0. econs; i.
  - rewrite remove_covered; [|eauto]. rewrite (@remove_covered mem2_tgt); [|eauto].
    rewrite COVER. refl.
  - revert GET. erewrite Memory.remove_o; eauto. condtac; ss.
    erewrite (@Memory.remove_o mem2_src); eauto. condtac; ss. eauto.
  - split; i.
    + erewrite Memory.remove_o in H; try exact SRC.
      erewrite Memory.remove_o; try exact TGT. condtac; ss.
      rewrite <- RESERVE. ss.
    + erewrite Memory.remove_o in H; try exact TGT.
      erewrite Memory.remove_o; try exact SRC. condtac; ss.
      rewrite RESERVE. ss.
Qed.

Lemma sim_memory_closed_timemap
      mem_src mem_tgt
      tm
      (SIM: sim_memory mem_src mem_tgt)
      (TGT: Memory.closed_timemap tm mem_tgt):
  Memory.closed_timemap tm mem_src.
Proof.
  ii. exploit TGT; eauto. i. des.
  exploit sim_memory_get; eauto. i. des.
  inv MSG. eauto.
Qed.

Lemma sim_memory_closed_view
      mem_src mem_tgt
      view
      (SIM: sim_memory mem_src mem_tgt)
      (TGT: Memory.closed_view view mem_tgt):
  Memory.closed_view view mem_src.
Proof.
  econs.
  - eapply sim_memory_closed_timemap; eauto. apply TGT.
  - eapply sim_memory_closed_timemap; eauto. apply TGT.
Qed.

Lemma sim_memory_closed_opt_view
      mem_src mem_tgt
      view
      (SIM: sim_memory mem_src mem_tgt)
      (TGT: Memory.closed_opt_view view mem_tgt):
  Memory.closed_opt_view view mem_src.
Proof.
  inv TGT; econs. eapply sim_memory_closed_view; eauto.
Qed.

Lemma sim_memory_closed_message
      mem_src mem_tgt
      msg
      (SIM: sim_memory mem_src mem_tgt)
      (TGT: Memory.closed_message msg mem_tgt):
  Memory.closed_message msg mem_src.
Proof.
  inv TGT; ss. econs. eapply sim_memory_closed_opt_view; eauto.
Qed.

(* cap *)

Lemma sim_memory_adjacent_src
      mem_src mem_tgt
      loc from1 to1 from2 to2
      (SIM: sim_memory mem_src mem_tgt)
      (CLOSED_SRC: Memory.closed mem_src)
      (CLOSED_TGT: Memory.closed mem_tgt)
      (ADJ: Memory.adjacent loc from1 to1 from2 to2 mem_src)
      (TS: Time.lt to1 from2):
  exists from1' to2',
    Memory.adjacent loc from1' to1 from2 to2' mem_tgt.
Proof.
  dup SIM. inv SIM0. inv ADJ. clear RESERVE TS0.
  assert (GET1_TGT: exists from1' m1', Memory.get loc to1 mem_tgt = Some (from1', m1')).
  { exploit Memory.get_ts; try exact GET1. i. des.
    { subst. esplits. eapply CLOSED_TGT. }
    destruct (COVER loc to1). exploit H; i.
    { econs; try exact GET1. econs; eauto. refl. }
    inv x. inv ITV. ss. inv TO; cycle 1.
    { inv H1. esplits; eauto. }
    exfalso.
    destruct (Time.le_lt_dec to from2).
    { exploit MSG; eauto. i. des.
      exploit (EMPTY to); eauto. i. congr. }
    destruct (COVER loc from2). exploit H3; i.
    { econs; eauto. econs; eauto. econs. ss. }
    inv x. inv ITV. ss. inv TO.
    - exploit Memory.get_ts; try exact GET2. i. des.
      { subst. inv FROM0. }
      exploit Memory.get_ts; try exact GET0. i. des.
      { subst. inv H4. }
      exploit Memory.get_disjoint; [exact GET2|exact GET0|..]. i. des.
      { timetac. }
      destruct (Time.le_lt_dec to2 to0).
      + apply (x3 to2); econs; ss; try refl.
        etrans; try exact FROM0. ss.
      + apply (x3 to0); econs; ss; try refl.
        econs. ss.
    - inv H4. exploit (EMPTY to0); eauto; try refl. i. congr.
  }
  assert (GET2_TGT: exists to2' m2', Memory.get loc to2' mem_tgt = Some (from2, m2')).
  { exploit Memory.get_ts; try exact GET2. i. des.
    { subst. inv TS. }
    exploit Memory.max_ts_spec; try exact GET2. i. des.
    clear from msg GET.
    erewrite sim_memory_max_ts in MAX; eauto.
    exploit TimeFacts.lt_le_lt; try exact x0; try exact MAX. i.
    exploit Memory.next_exists; try exact x1; try eapply CLOSED_TGT. i. des.
    destruct (TimeFacts.le_lt_dec from from2).
    - inv l; cycle 1.
      { inv H. esplits; eauto. }
      destruct (COVER loc from2). exploit H1; i.
      { econs; try exact x2. econs; ss. econs; ss. }
      inv x. inv ITV. ss. inv TO; cycle 1.
      { inv H2. exploit (EMPTY to0); eauto; try refl. i. congr. }
      exploit Memory.get_disjoint; [exact GET2|exact GET|..]. i. des.
      { subst. timetac. }
      exfalso.
      destruct (TimeFacts.le_lt_dec to2 to0).
      + apply (x5 to2); econs; ss; try refl.
        etrans; try exact FROM. ss.
      + apply (x5 to0); econs; ss; try refl.
        * econs. ss.
        * etrans; eauto.
    - destruct (TimeFacts.le_lt_dec to2 from).
      + destruct (COVER loc to2). exploit H; i.
        { econs; eauto. econs; ss. refl. }
        inv x. inv ITV. ss.
        exploit (x4 to0); eauto; try congr.
        { eapply TimeFacts.lt_le_lt; try exact TO; ss. }
        destruct (Time.le_lt_dec to to0); ss.
        exploit Memory.get_ts; try exact x2. i. des.
        { subst. inv x3. }
        exploit Memory.get_disjoint; [exact x2|exact GET|..]. i. des.
        { subst. timetac. }
        exfalso.
        apply (x6 to); econs; ss; try refl.
        etrans; try exact FROM.
        eapply TimeFacts.le_lt_lt; try exact x5. ss.
      + destruct (COVER loc from). exploit H; i.
        { econs; try exact GET2. econs; ss. econs. ss. }
        inv x. inv ITV. ss.
        destruct (TimeFacts.le_lt_dec to to0).
        * exploit Memory.get_ts; try exact x2. i. des.
          { subst. inv x3. }
          exploit Memory.get_ts; try exact GET. i. des.
          { subst. timetac. }
          exploit Memory.get_disjoint; [exact x2|exact GET|..]. i. des.
          { subst. timetac. }
          exfalso.
          apply (x7 to); econs; ss; try refl.
          eapply TimeFacts.lt_le_lt; try exact FROM. econs. ss.
        * exploit (x4 to0); ss; try congr.
          eapply TimeFacts.lt_le_lt; try exact TO; ss.
  }
  des. esplits. econs; eauto; i.
  { exploit Memory.get_ts; try exact GET2_TGT. i. des.
    - subst. inv TS.
    - etrans; eauto. }
  destruct (Memory.get loc ts mem_tgt) as [[]|] eqn:GET; ss.
  exfalso.
  exploit Memory.get_ts; try exact GET. i. des.
  { subst. inv TS1. }
  destruct (COVER loc ts). exploit H0; i.
  { econs; eauto. econs; ss. refl. }
  inv x. inv ITV. ss.
  destruct (TimeFacts.le_lt_dec to from2).
  { exploit (EMPTY to); try congr.
    eapply TimeFacts.lt_le_lt; try exact TS1. ss. }
  exploit Memory.get_ts; try exact GET2. i. des.
  { subst. inv TS. }
  exploit Memory.get_ts; try exact GET0. i. des.
  { subst. inv l. }
  exploit Memory.get_disjoint; [exact GET2|exact GET0|..]. i. des.
  { subst. timetac. }
  destruct (TimeFacts.le_lt_dec to2 to).
  - apply (x3 to2); econs; ss; try refl.
    etrans; try exact x1.
    eapply TimeFacts.lt_le_lt; try exact TS2. ss.
  - apply (x3 to); econs; ss; try refl. econs. ss.
Qed.

Lemma sim_memory_adjacent_tgt
      mem_src mem_tgt
      loc from1 to1 from2 to2
      (SIM: sim_memory mem_src mem_tgt)
      (CLOSED_SRC: Memory.closed mem_src)
      (CLOSED_TGT: Memory.closed mem_tgt)
      (ADJ: Memory.adjacent loc from1 to1 from2 to2 mem_tgt)
      (TS: Time.lt to1 from2):
  exists from1' to2',
    Memory.adjacent loc from1' to1 from2 to2' mem_src.
Proof.
  dup SIM. inv SIM0. inv ADJ. clear RESERVE TS0.
  assert (GET1_SRC: exists from1' m1', Memory.get loc to1 mem_src = Some (from1', m1')).
  { exploit MSG; try exact GET1. i. des. eauto. }
  assert (GET2_SRC: exists to2' m2', Memory.get loc to2' mem_src = Some (from2, m2')).
  { exploit Memory.get_ts; try exact GET2. i. des.
    { subst. inv TS. }
    exploit Memory.max_ts_spec; try exact GET2. i. des.
    clear from msg GET.
    erewrite <- sim_memory_max_ts in MAX; eauto.
    exploit TimeFacts.lt_le_lt; try exact x0; try exact MAX. i.
    exploit Memory.next_exists; try exact x1; try eapply CLOSED_SRC. i. des.
    destruct (TimeFacts.le_lt_dec from from2).
    - inv l; cycle 1.
      { inv H. esplits; eauto. }
      destruct (COVER loc from2). exploit H0; i.
      { econs; try exact x2. econs; ss. econs; ss. }
      inv x. inv ITV. ss. inv TO; cycle 1.
      { inv H2. exploit (EMPTY to0); eauto; try refl. i. congr. }
      exploit Memory.get_disjoint; [exact GET2|exact GET|..]. i. des.
      { subst. timetac. }
      exfalso.
      destruct (TimeFacts.le_lt_dec to2 to0).
      + apply (x5 to2); econs; ss; try refl.
        etrans; try exact FROM. ss.
      + apply (x5 to0); econs; ss; try refl.
        * econs. ss.
        * etrans; eauto.
    - destruct (TimeFacts.le_lt_dec to2 from).
      + destruct (COVER loc to2). exploit H0; i.
        { econs; eauto. econs; ss. refl. }
        inv x. inv ITV. ss.
        exploit (x4 to0); eauto; try congr.
        { eapply TimeFacts.lt_le_lt; try exact TO; ss. }
        destruct (Time.le_lt_dec to to0); ss.
        exploit Memory.get_ts; try exact x2. i. des.
        { subst. inv x3. }
        exploit Memory.get_disjoint; [exact x2|exact GET|..]. i. des.
        { subst. timetac. }
        exfalso.
        apply (x6 to); econs; ss; try refl.
        etrans; try exact FROM.
        eapply TimeFacts.le_lt_lt; try exact x5. ss.
      + destruct (COVER loc from). exploit H0; i.
        { econs; try exact GET2. econs; ss. econs. ss. }
        inv x. inv ITV. ss.
        destruct (TimeFacts.le_lt_dec to to0).
        * exploit Memory.get_ts; try exact x2. i. des.
          { subst. inv x3. }
          exploit Memory.get_ts; try exact GET. i. des.
          { subst. timetac. }
          exploit Memory.get_disjoint; [exact x2|exact GET|..]. i. des.
          { subst. timetac. }
          exfalso.
          apply (x7 to); econs; ss; try refl.
          eapply TimeFacts.lt_le_lt; try exact FROM. econs. ss.
        * exploit (x4 to0); ss; try congr.
          eapply TimeFacts.lt_le_lt; try exact TO; ss.
  }
  des. esplits. econs; eauto; i.
  { exploit Memory.get_ts; try exact GET2_SRC. i. des.
    - subst. inv TS.
    - etrans; eauto. }
  destruct (Memory.get loc ts mem_src) as [[]|] eqn:GET; ss.
  exfalso.
  exploit Memory.get_ts; try exact GET. i. des.
  { subst. inv TS1. }
  destruct (COVER loc ts). exploit H; i.
  { econs; eauto. econs; ss. refl. }
  inv x. inv ITV. ss.
  destruct (TimeFacts.le_lt_dec to from2).
  { exploit (EMPTY to); try congr.
    eapply TimeFacts.lt_le_lt; try exact TS1. ss. }
  exploit Memory.get_ts; try exact GET2. i. des.
  { subst. inv TS. }
  exploit Memory.get_ts; try exact GET0. i. des.
  { subst. inv l. }
  exploit Memory.get_disjoint; [exact GET2|exact GET0|..]. i. des.
  { subst. timetac. }
  destruct (TimeFacts.le_lt_dec to2 to).
  - apply (x3 to2); econs; ss; try refl.
    etrans; try exact x1.
    eapply TimeFacts.lt_le_lt; try exact TS2. ss.
  - apply (x3 to); econs; ss; try refl. econs. ss.
Qed.

Lemma sim_memory_cap_get_src
      mem1_src mem2_src
      mem1_tgt mem2_tgt
      loc from to msg
      (MEM1: sim_memory mem1_src mem1_tgt)
      (CAP_SRC: Memory.cap mem1_src mem2_src)
      (CAP_TGT: Memory.cap mem1_tgt mem2_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt)
      (GET1_SRC: Memory.get loc to mem1_src = None)
      (GET2_SRC: Memory.get loc to mem2_src = Some (from, msg)):
  <<MSG: msg = Message.reserve>> /\
  <<GET1_TGT: Memory.get loc to mem1_tgt = None>> /\
  <<GET2_TGT: Memory.get loc to mem2_tgt = Some (from, msg)>>.
Proof.
  exploit Memory.cap_inv; try exact CAP_SRC; eauto. i. des; try congr.
  - subst.
    exploit sim_memory_adjacent_src; try exact x1; eauto. i. des.
    inv CAP_TGT. exploit MIDDLE; eauto. i. splits; auto.
    inv x3. apply EMPTY; eauto. refl.
  - subst.
    erewrite sim_memory_max_ts; eauto.
    inv CAP_TGT. splits; auto.
    destruct (Memory.get loc (Time.incr (Memory.max_ts loc mem1_tgt)) mem1_tgt) as [[]|] eqn:MAX; ss.
    exploit Memory.max_ts_spec; eauto. i. des.
    specialize (Time.incr_spec (Memory.max_ts loc mem1_tgt)). i. timetac.
Qed.

Lemma sim_memory_cap_get_tgt
      mem1_src mem2_src
      mem1_tgt mem2_tgt
      loc from to msg
      (MEM1: sim_memory mem1_src mem1_tgt)
      (CAP_SRC: Memory.cap mem1_src mem2_src)
      (CAP_TGT: Memory.cap mem1_tgt mem2_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt)
      (GET1_TGT: Memory.get loc to mem1_tgt = None)
      (GET2_TGT: Memory.get loc to mem2_tgt = Some (from, msg)):
  <<MSG: msg = Message.reserve>> /\
  <<GET1_SRC: Memory.get loc to mem1_src = None>> /\
  <<GET2_SRC: Memory.get loc to mem2_src = Some (from, msg)>>.
Proof.
  exploit Memory.cap_inv; try exact CAP_TGT; eauto. i. des; try congr.
  - subst.
    exploit sim_memory_adjacent_tgt; try exact x1; eauto. i. des.
    inv CAP_SRC. exploit MIDDLE; eauto. i. splits; auto.
    inv x3. apply EMPTY; eauto. refl.
  - subst.
    erewrite <- sim_memory_max_ts; eauto.
    inv CAP_SRC. splits; auto.
    destruct (Memory.get loc (Time.incr (Memory.max_ts loc mem1_src)) mem1_src) as [[]|] eqn:MAX; ss.
    exploit Memory.max_ts_spec; eauto. i. des.
    specialize (Time.incr_spec (Memory.max_ts loc mem1_src)). i. timetac.
Qed.

Lemma sim_memory_cap
      mem1_src mem2_src
      mem1_tgt mem2_tgt
      (MEM1: sim_memory mem1_src mem1_tgt)
      (CAP_SRC: Memory.cap mem1_src mem2_src)
      (CAP_TGT: Memory.cap mem1_tgt mem2_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  <<MEM2: sim_memory mem2_src mem2_tgt>>.
Proof.
  econs; i; try split; i.
  - inv H.
    destruct (Memory.get loc to mem1_src) as [[]|] eqn:GET1.
    + inv CAP_SRC. exploit SOUND; eauto. i.
      rewrite x in GET. inv GET.
      eapply cap_covered; eauto.
      inv MEM1. rewrite <- COVER.
      econs; eauto.
    + exploit sim_memory_cap_get_src; eauto. i. des.
      econs; eauto.
  - inv H.
    destruct (Memory.get loc to mem1_tgt) as [[]|] eqn:GET1.
    + inv CAP_TGT. exploit SOUND; eauto. i.
      rewrite x in GET. inv GET.
      eapply cap_covered; eauto.
      inv MEM1. rewrite COVER.
      econs; eauto.
    + exploit sim_memory_cap_get_tgt; eauto. i. des.
      econs; eauto.
  - destruct (Memory.get loc to mem1_tgt) as [[]|] eqn:GET1.
    + inv CAP_TGT. exploit SOUND; eauto. i.
      rewrite x in GET. inv GET.
      inv MEM1. exploit MSG; eauto. i. des.
      inv CAP_SRC. exploit SOUND; eauto. i.
      esplits; eauto.
    + exploit sim_memory_cap_get_tgt; eauto. i. des.
      esplits; eauto. refl.
  - destruct (Memory.get loc to mem1_src) as [[]|] eqn:GET1.
    + inv CAP_SRC. exploit SOUND; eauto. i.
      rewrite x in H. inv H.
      inv MEM1. rewrite RESERVE in GET1.
      inv CAP_TGT. exploit SOUND0; eauto.
    + exploit sim_memory_cap_get_src; eauto. i. des. auto.
  - destruct (Memory.get loc to mem1_tgt) as [[]|] eqn:GET1.
    + inv CAP_TGT. exploit SOUND; eauto. i.
      rewrite x in H. inv H.
      inv MEM1. rewrite <- RESERVE in GET1.
      inv CAP_SRC. exploit SOUND0; eauto.
    + exploit sim_memory_cap_get_tgt; eauto. i. des. auto.
Qed.

(* fulfill_step *)

Lemma fulfill_write_sim_memory
      lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2
      (FULFILL: fulfill_step lc1 sc1 loc from to val releasedm released ord lc2 sc2)
      (REL_WF: View.opt_wf releasedm)
      (REL_CLOSED: Memory.closed_opt_view releasedm mem1)
      (ORD: Ordering.le ord Ordering.relaxed)
      (WF1: Local.wf lc1 mem1)
      (SC1: Memory.closed_timemap sc1 mem1)
      (MEM1: Memory.closed mem1):
  exists released' mem2',
    <<STEP: Local.write_step lc1 sc1 mem1 loc from to val releasedm released' ord lc2 sc2 mem2' (Memory.op_kind_lower (Message.concrete val released))>> /\
    <<REL_LE: View.opt_le released' released>> /\
    <<MEM: sim_memory mem2' mem1>>.
Proof.
  inv FULFILL.
  exploit TViewFacts.write_future_fulfill;
    try exact REL_CLOSED; try exact SC1; eauto; try by apply WF1.
  { apply WF1. eapply Memory.remove_get0. eauto. }
  i. des.
  exploit MemorySplit.remove_promise_remove;
    try exact REMOVE; eauto; try apply WF1; try by econs; eauto.
  { econs. inv REL_LE; try apply Time.bot_spec.
    cut (Time.le (View.rlx (View.unwrap (Some lhs)) loc)
                 (View.rlx (View.unwrap (Some rhs)) loc)).
    { i. etrans; eauto.
      cut (Memory.message_to (Message.concrete val (Some rhs)) loc to).
      { i. inv H1. auto. }
      eapply MEM1. apply WF1. eapply Memory.remove_get0. eauto. }
    destruct lhs; destruct rhs; inv LE; ss. }
  i. des.
  esplits; eauto.
  - econs; eauto.
    i. destruct ord; inv ORD; inv H.
  - eapply promise_lower_sim_memory; eauto. econs.
Qed.

Lemma promise_fulfill_write_sim_memory
      lc0 sc0 mem0 loc from to val releasedm released ord lc1 lc2 sc2 mem2 kind
      (PROMISE: Local.promise_step lc0 mem0 loc from to (Message.concrete val released) lc1 mem2 kind)
      (FULFILL: fulfill_step lc1 sc0 loc from to val releasedm released ord lc2 sc2)
      (REL_WF: View.opt_wf releasedm)
      (REL_CLOSED: Memory.closed_opt_view releasedm mem0)
      (ORD: Ordering.le Ordering.strong_relaxed ord -> Memory.nonsynch_loc loc (Local.promises lc0))
      (WF0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0):
  exists released' mem2',
    <<STEP: Local.write_step lc0 sc0 mem0 loc from to val releasedm released' ord lc2 sc2 mem2' kind>> /\
    <<REL_LE: View.opt_le released' released>> /\
    <<MEM: sim_memory mem2' mem2>> /\
    <<REL: released' = TView.write_released (Local.tview lc0) sc0 loc to releasedm ord>>.
Proof.
  exploit Local.promise_step_future; eauto. i. des.
  inv PROMISE. inv FULFILL. ss.
  exploit TViewFacts.write_future_fulfill; try exact REL_WF; eauto; try by apply WF2.
  { eapply Memory.future_closed_opt_view; eauto. }
  { eapply Memory.promise_get2; eauto. inv PROMISE0; ss. }
  s. i. des.
  exploit MemorySplit.remove_promise_remove;
    try exact REMOVE; eauto; try apply WF2; try by econs; eauto.
  { econs. inv REL_LE; try apply Time.bot_spec.
    cut (Time.le (View.rlx (View.unwrap (Some lhs)) loc)
                 (View.rlx (View.unwrap (Some rhs)) loc)).
    { i. etrans; eauto.
      cut (Memory.message_to (Message.concrete val (Some rhs)) loc to).
      { i. inv H1. auto. }
      eapply CLOSED2. apply WF2. eapply Memory.remove_get0. eauto. }
    destruct lhs; destruct rhs; inv LE; ss. }
  i. des.
  esplits; eauto.
  - econs; eauto. econs; eauto.
    eapply MemoryMerge.promise_promise_promise; eauto.
  - eapply promise_lower_sim_memory; eauto. econs.
Qed.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.
Require Import Ext_Cons.Arrow.
Require Import Basic_Cons.Terminal.
Require Import Basic_Cons.Equalizer.
Require Import Basic_Cons.Facts.Equalizer_Monic.
Require Import Coq_Cats.Type_Cat.Card_Restriction.
Require Import Archetypal.Discr.Discr Archetypal.Discr.NatFacts.

Require Import Limits.GenProd_GenSum.
Require Import Limits.Limit.

Local Open Scope functor_scope.

Section GenProd_Eq_Complete.
  Context {C : Category}.

  Local Ltac ElimUnit := repeat match goal with [H : unit |- _] => destruct H end.

  Section GenProd_Eq_Limits.
    Context {J : Category}.

    Context {OProd : ∀ (map : J → C), GenProd map}
            {HProd : ∀ (map : (Arrow J) → C), GenProd map}
            {Eqs : Has_Equalizers C}
    .

    Section Limits_Exist.
      Context (D : J –≻ C).

      Local Notation DTarg := (fun f => (D _o (Targ f))%object) (only parsing).
      Local Notation DF := Discr_Func (only parsing).
      Local Notation OPR := (OProd (D _o)%object) (only parsing).
      Local Notation HPR := (HProd DTarg) (only parsing).

      Program Definition Projs_Cone : Cone (DF DTarg) :=
        {|
          cone_apex := Const_Func 1 (OPR _o tt);
          cone_edge := {|Trans := fun f => Trans (cone_edge OPR) (Targ f)|}
        |}.

      Definition Projs : (OPR –≻ HPR)%morphism := Trans (LRKE_morph_ex HPR Projs_Cone) tt.

      Program Definition D_imgs_Cone : Cone (DF DTarg) :=
        {|
          cone_apex := Const_Func 1 (OPR _o tt);
          cone_edge :=
            {|
              Trans :=
                fun f =>
                  (D _a (Arr f) ∘ (Trans (cone_edge OPR) (Orig f)))%morphism
            |}
        |}.

      Definition D_imgs : (OPR –≻ HPR)%morphism := Trans (LRKE_morph_ex HPR D_imgs_Cone) tt.

      Program Definition Lim_Cone : Cone D :=
        {|
          cone_apex := Const_Func 1 (Eqs _ _ Projs D_imgs);
          cone_edge :=
            {|Trans :=
                fun d =>
                  ((Trans (cone_edge OPR) d) ∘ (equalizer_morph (Eqs _ _ Projs D_imgs)))%morphism
            |}
        |}.

      Next Obligation.
      Proof.
        simpl_ids.
        set (W :=
               f_equal
                 (fun t :
                        (((Const_Func 1 (((OProd (D _o)) _o) tt)%object)
                             ∘ (Functor_To_1_Cat (Discr_Cat (Arrow J))))
                          –≻ (DF DTarg))%nattrans
                  =>
                    ((Trans t {|Arr := h|}) ∘ (equalizer_morph (Eqs _ _ Projs D_imgs)))%morphism
                 )
                 (cone_morph_com (LRKE_morph_ex HPR D_imgs_Cone))
            ).
        set (W' :=
               f_equal
                 (fun t :
                        (((Const_Func 1 (((OProd (D _o)) _o) tt)%object)
                             ∘ (Functor_To_1_Cat (Discr_Cat (Arrow J))))
                          –≻ (DF DTarg))%nattrans
                  =>
                    (Trans t {|Arr := h|} ∘ (equalizer_morph (Eqs _ _ Projs D_imgs)))%morphism
                 )
                 (cone_morph_com (LRKE_morph_ex HPR Projs_Cone))
            ).
        clearbody W W'.
        rewrite (assoc_sym _ _ ((D _a) h)).
        cbn in *.
        fold D_imgs in W.
        fold Projs in W'.
        rewrite W'.
        etransitivity; [|symmetry; apply W].
        clear W W'.
        repeat rewrite assoc.
        apply (
            f_equal
              (fun f =>
                 compose f
                         (Trans
                            (HProd (fun f : Arrow J => (D _o)%object (Targ f)))
                            {| Arr := h |}
                         )
              )
          ).
        apply (
            f_equal (
                fun f =>
                  compose f
                          (
                            ((HProd (fun f : Arrow J => (D _o)%object (Targ f))) _a) tt
                          )
              )
          ).
        apply equalizer_morph_com.
      Qed.

      Next Obligation.
      Proof.
        symmetry.
        apply Lim_Cone_obligation_1.
      Qed.

      Section Every_Cone_Equalizes.
        Context (Cn : Cone D).

        Local Hint Extern 1 => progress cbn.

        Program Definition Cone_to_DF_DCone : Cone (DF (D _o)%object) :=
          {|
            cone_apex := Cn;
            cone_edge :=
              @NatTrans_compose _ _
                                (Cn ∘ (Functor_To_1_Cat (Discr_Cat J)))
                                (Discr_Func ((Cn ∘ (Functor_To_1_Cat J))%functor _o)%object) _
                                {|Trans := fun _ => id |} (Discretize (cone_edge Cn))
          |}.

        Definition From_Cone_to_OPR : (Cn –≻ OPR)%morphism := Trans (LRKE_morph_ex OPR Cone_to_DF_DCone) tt.

        Program Definition Cone_to_DF_DTrag_Cone : Cone (DF DTarg) :=
          {|
            cone_apex := Cn;
            cone_edge := {|Trans := fun c => Trans (Discretize (cone_edge Cn)) (Targ c)|}
          |}.

        Program Definition Cone_Morph_From_Cone_to_DF_DTrag_Cone_to_HPR_1 :
          Cone_Morph _ Cone_to_DF_DTrag_Cone HPR :=
          {|
            cone_morph :=
              {|Trans :=
                  fun f =>
                    match f as u return (((Cn _o) u)%object –≻ (_ u))%morphism
                    with
                    | tt => (Projs ∘ From_Cone_to_OPR)%morphism
                    end
              |}
          |}.

        Next Obligation.
        Proof.
          ElimUnit.
          do 2 rewrite From_Term_Cat.
          auto.
        Qed.

        Next Obligation.
        Proof.
          symmetry.
          apply Cone_Morph_From_Cone_to_DF_DTrag_Cone_to_HPR_1_obligation_1.
        Qed.

        Next Obligation.
        Proof.
          apply NatTrans_eq_simplify.
          extensionality x; cbn.
          unfold Projs, From_Cone_to_OPR.
          set (H :=
                 f_equal
                   (fun w :
                          ((Projs_Cone ∘ (Functor_To_1_Cat (Discr_Cat (Arrow J))))
                             –≻ (DF DTarg))%nattrans
                    =>
                      (
                        (Trans w x) ∘
                                   (
                                     Trans
                                       (LRKE_morph_ex (OProd (D _o)%object) Cone_to_DF_DCone)
                                       tt
                                   )
                      )%morphism
                   )
                   (
                     cone_morph_com
                       (
                         LRKE_morph_ex
                           (HProd (fun f : Arrow J => (D _o)%object (Targ f)))
                           Projs_Cone
                       )
                   )
              );
            clearbody H; cbn in H.
          repeat rewrite assoc_sym in H.
          repeat rewrite assoc_sym.
          etransitivity; [|apply H]; clear H.
          set (H :=
                 f_equal
                   (
                     fun w :
                           ((Cone_to_DF_DCone ∘ (Functor_To_1_Cat (Discr_Cat J)))
                              –≻ (DF (D _o)%object))%nattrans
                     =>
                       Trans w (Targ x)
                   )
                   (cone_morph_com (LRKE_morph_ex (OProd (D _o)%object) Cone_to_DF_DCone))
              ).
          cbn in *.
          rewrite From_Term_Cat in H; simpl_ids in H.
          trivial.
        Qed.

        Program Definition Cone_Morph_From_Cone_to_DF_DTrag_Cone_to_HPR_2 :
          Cone_Morph _ Cone_to_DF_DTrag_Cone HPR :=
          {|
            cone_morph :=
              {|Trans :=
                  fun f =>
                    match f as u return (((Cn _o)%object u) –≻ (_ u))%morphism
                    with
                    | tt => (D_imgs ∘ From_Cone_to_OPR)%morphism
                    end
              |}
          |}.

        Next Obligation.
        Proof.
          ElimUnit.
          do 2 rewrite From_Term_Cat; simpl_ids; trivial.
        Qed.

        Next Obligation.
        Proof.
          symmetry.
          apply Cone_Morph_From_Cone_to_DF_DTrag_Cone_to_HPR_2_obligation_1.
        Qed.

        Next Obligation.
        Proof.
          apply NatTrans_eq_simplify.
          extensionality x.
          cbn.
          unfold D_imgs, From_Cone_to_OPR.
          set (H :=
                 f_equal
                   (
                     fun w :
                           ((D_imgs_Cone ∘ (Functor_To_1_Cat (Discr_Cat (Arrow J))))
                             –≻ (DF DTarg))%nattrans
                     =>
                       (
                         (Trans w x) ∘
                                    (
                                      Trans
                                        (LRKE_morph_ex (OProd (D _o)%object) Cone_to_DF_DCone)
                                        tt
                                    )
                       )%morphism
                   )
                   (
                     cone_morph_com
                       (LRKE_morph_ex (HProd (fun f : Arrow J => (D _o)%object (Targ f))) D_imgs_Cone)
                   )
              );
            clearbody H; cbn in H.
          repeat rewrite assoc_sym in H.
          repeat rewrite assoc_sym.
          etransitivity; [|apply H]; clear H.
          set (H :=
                 f_equal
                   (
                     fun w :
                           ((Cone_to_DF_DCone ∘ (Functor_To_1_Cat (Discr_Cat J)))
                              –≻ (DF (D _o)%object))%nattrans
                     =>
                       (((D _a) (Arr x)) ∘ (Trans w (Orig x)))%morphism
                   )
                   (cone_morph_com (LRKE_morph_ex (OProd (D _o)%object) Cone_to_DF_DCone))
              );
            clearbody H; cbn in H.
          rewrite From_Term_Cat in H; simpl_ids in H.
          repeat rewrite assoc_sym in H.
          repeat rewrite assoc_sym.
          etransitivity; [|apply H]; clear H.
          cbn_rewrite <- (@Trans_com _ _ _ _ Cn).
          rewrite From_Term_Cat; auto.
        Qed.

        Lemma From_Cone_to_Obj_Prod_Equalizes :
          (Projs ∘ From_Cone_to_OPR = D_imgs ∘ From_Cone_to_OPR)%morphism.
        Proof.
          match goal with
            [|- ?A = ?B] =>
            change A with (Trans Cone_Morph_From_Cone_to_DF_DTrag_Cone_to_HPR_1 tt);
              change B with (Trans Cone_Morph_From_Cone_to_DF_DTrag_Cone_to_HPR_2 tt)
          end.
          match goal with
            [|- Trans ?A tt = Trans ?B tt] =>
            cutrewrite (A = B); trivial
          end.
          apply (LRKE_morph_unique HPR).
        Qed.

        Definition From_Cone_to_Lim_Cone : (Cn –≻ Lim_Cone)%morphism :=
          equalizer_morph_ex _  From_Cone_to_Obj_Prod_Equalizes.

        Program Definition Cone_Morph_to_Lim_Cone : Cone_Morph D Cn Lim_Cone :=
          {|
            cone_morph :=
              {|
                Trans :=
                  fun c =>
                    match c as u return ((Cn _o u)%object –≻ _)%morphism with
                      tt => From_Cone_to_Lim_Cone
                    end
              |}
          |}.

        Next Obligation.
        Proof.
          ElimUnit.
          rewrite From_Term_Cat; auto.
        Qed.

        Next Obligation.
          symmetry.
          apply Cone_Morph_to_Lim_Cone_obligation_1.
        Qed.

        Next Obligation.
        Proof.
          apply NatTrans_eq_simplify.
          extensionality x.
          unfold From_Cone_to_Lim_Cone.
          cbn in *.
          set (H :=
                 equalizer_morph_ex_com
                   (Eqs _ _ Projs D_imgs)
                   From_Cone_to_Obj_Prod_Equalizes
              );
            clearbody H; cbn in H.
          simpl_ids.
          rewrite assoc.
          match goal with
            [|- _ = (?A ∘ ?B)%morphism] =>
            replace B with From_Cone_to_OPR
          end.
          clear H.
          unfold From_Cone_to_OPR.
          set (H :=
                 f_equal
                   (
                     fun w :
                           ((Cone_to_DF_DCone ∘ (Functor_To_1_Cat (Discr_Cat J)))
                              –≻ (DF (D _o)%object))%nattrans
                     =>
                       Trans w x
                   )
                   (cone_morph_com (LRKE_morph_ex (OProd (D _o)%object) Cone_to_DF_DCone))
              ).
          cbn in H.
          rewrite From_Term_Cat in H; simpl_ids in H.
          trivial.
        Qed.

      End Every_Cone_Equalizes.

      Section Cone_Morph_to_Lim_Cone_Cone_Morph_to_OPR.
        Context {Cn : Cone D} (h : Cone_Morph _ Cn Lim_Cone).

        Program Definition Cone_Morph_to_Lim_Cone_Cone_Morph_to_OPR :
          Cone_Morph _ (Cone_to_DF_DCone Cn) OPR :=
          {|
            cone_morph :=
              {|
                Trans :=
                  fun c =>
                    match c as u return (((Cn _o) u) –≻ (((OProd (D _o)) _o) u))%object%morphism with
                    | tt => (equalizer_morph (Eqs _ _ Projs D_imgs) ∘ Trans h tt)%morphism
                    end
              |}
          |}.

        Next Obligation.
        Proof.
          ElimUnit.
          rewrite From_Term_Cat; auto.
        Qed.

        Next Obligation.
        Proof.
          symmetry.
          apply Cone_Morph_to_Lim_Cone_Cone_Morph_to_OPR_obligation_1.
        Qed.

        Next Obligation.
        Proof.
          apply NatTrans_eq_simplify.
          extensionality x.
          cbn.
          set (H :=
                 f_equal
                   (fun w : ((Cn ∘ (Functor_To_1_Cat J)) –≻ D)%nattrans => Trans w x)
                   (cone_morph_com h)
              ).
          cbn in H.
          simpl_ids in H.
          rewrite From_Term_Cat; simpl_ids.
          rewrite assoc in H.
          trivial.
        Qed.

      End Cone_Morph_to_Lim_Cone_Cone_Morph_to_OPR.

      Local Notation CMCOPR := Cone_Morph_to_Lim_Cone_Cone_Morph_to_OPR (only parsing).

      Program Definition Lim_Cone_is_Limit : Limit D :=
        {|
          LRKE := Lim_Cone;
          LRKE_morph_ex := Cone_Morph_to_Lim_Cone
        |}.

      Next Obligation.
      Proof.
        set (H := LRKE_morph_unique (OProd (D _o)%object) _ (CMCOPR h) (CMCOPR h')).
        apply (
            f_equal
              (fun w : ((Cone_to_DF_DCone Cn) –≻ (OProd (D _o)%object))%nattrans => Trans w tt)
          ) in H.
        cbn in H.
        apply NatTrans_eq_simplify.
        extensionality x; destruct x.
        apply (@mono_morphism_monomorphic _ _ _ (@Equalizer_Monic _ _ _ _ _ (Eqs _ _ Projs D_imgs))).
        trivial.
      Qed.

    End Limits_Exist.
  End GenProd_Eq_Limits.

  Section Restricted_Limits.
    Context (P : Card_Restriction)
            {CHRP : ∀ (A : Type) (map : A → C), (P A) → GenProd map}
            {HE : Has_Equalizers C}
    .

    Definition Restr_GenProd_Eq_Restr_Limits : Has_Restr_Limits C P :=
      fun J D PJ PA =>
        @Lim_Cone_is_Limit
          J
          (fun map => CHRP J map PJ)
          (fun map => CHRP (Arrow J) map PA)
          HE
          D
    .

  End Restricted_Limits.

  Section Complete.
    Context {CHAP : ∀ (A : Type) (map : A → C), GenProd map} {HE : Has_Equalizers C}.

    Definition GenProd_Eq_Complete : Complete C :=
      fun J =>
        Local_to_Global_Right
          _
          _
          (fun D => @Lim_Cone_is_Limit J (CHAP J) (CHAP (Arrow J)) HE D)
    .

  End Complete.

End GenProd_Eq_Complete.

Section GenSum_CoEq_Complete.
  Context {C : Category}.

  Section GenSum_CoEq_CoLimits.
    Context {J : Category}
            {OSum : ∀ (map : J → C), GenSum map}
            {HSum : ∀ (map : (Arrow J) → C), GenSum map}
            {Eqs : Has_CoEqualizers C}
    .

    Section Limits_Exist.
      Context (D : J –≻ C).

      Program Definition CoLim_CoCone_is_CoLimit : CoLimit D :=
        @Lim_Cone_is_Limit
          (C^op)
          (J^op)
          (fun map => GenSum_to_GenProd (OSum map))
          (fun map => GenSum_to_GenProd (GenSum_IsoType (Arrow_OP_Iso J) HSum map))
          Eqs
          (Opposite_Functor D)
      .

    End Limits_Exist.
  End GenSum_CoEq_CoLimits.

  Section Restricted_CoLimits.
    Context (P : Card_Restriction)
            {CHRP : ∀ (A : Type) (map : A → C), (P A) → GenSum map}
            {HE : Has_CoEqualizers C}
    .

    Definition Restr_GenSum_CoEq_Restr_CoLimits : Has_Restr_CoLimits C P :=
      fun J D PJ PA =>
        @CoLim_CoCone_is_CoLimit
          J
          (fun map => CHRP J map PJ)
          (fun map => CHRP (Arrow J) map PA)
          HE
          D
    .

  End Restricted_CoLimits.

  Section CoComplete.
    Context {CHAP : ∀ (A : Type) (map : A → C), GenSum map}
            {HE : Has_CoEqualizers C}
    .

    Definition GenSum_CoEq_CoComplete : CoComplete C :=
      fun J =>
        Local_to_Global_Left
          _
          _
          (fun D => @CoLim_CoCone_is_CoLimit J (CHAP J) (CHAP (Arrow J)) HE D)
    .

  End CoComplete.

End GenSum_CoEq_Complete.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj27eqsynthconj6 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus lv1 lv0)).
Admitted.
QuickChick conj27eqsynthconj6.


From Equations Require Import Equations.
Require Import Coq.Lists.List.

Require Export SystemFR.RedTactics.

Opaque reducible_values.
Opaque makeFresh.

Lemma reducible_true:
  forall ρ, [ ρ ⊨ ttrue : T_bool ]v.
Proof.
  repeat step || simp_red.
Qed.

Lemma open_reducible_true:
  forall Θ Γ,
    [ Θ; Γ ⊨ ttrue : T_bool ].
Proof.
  unfold open_reducible,reduces_to, closed_term in *; steps;
    eauto using reducible_true with star.
Qed.

Lemma reducible_false:
  forall ρ, [ ρ ⊨ tfalse : T_bool ]v.
Proof.
  repeat step || simp_red.
Qed.

Lemma open_reducible_false:
  forall Θ Γ,
    [ Θ; Γ ⊨ tfalse : T_bool ].
Proof.
  unfold open_reducible,reduces_to, closed_term in *; steps;
    eauto using reducible_false with star.
Qed.

Lemma reducible_ite:
  forall ρ T b t1 t2,
    wf t1 0 ->
    wf t2 0 ->
    pfv t1 term_var = nil ->
    pfv t2 term_var = nil ->
    is_erased_term t1 ->
    is_erased_term t2 ->
    valid_interpretation ρ ->
    [ ρ ⊨ b : T_bool ] ->
    ([ b ≡ ttrue ] -> [ ρ ⊨ t1 : T ]) ->
    ([ b ≡ tfalse ] -> [ ρ ⊨ t2 : T ]) ->
    [ ρ ⊨ ite b t1 t2 : T ].
Proof.
  repeat step || top_level_unfold reduces_to ||
         top_level_unfold closed_term ||
         simp_red.

  - apply star_backstep_reducible with (ite ttrue t1 t2); repeat step || list_utils;
      auto with cbvlemmas; eauto with fv; eauto with wf.
    eapply backstep_reducible; repeat step || list_utils;
      eauto 2 with smallstep;
      eauto with fv;
      eauto with wf;
      eauto using equivalent_star.

  - apply star_backstep_reducible with (ite tfalse t1 t2); repeat step || list_utils;
      auto with cbvlemmas; eauto with fv; eauto with wf.
    eapply backstep_reducible; repeat step || list_utils;
      eauto 2 with smallstep;
      eauto with fv;
      eauto with wf;
      eauto using equivalent_star.
Qed.

Lemma open_reducible_ite:
  forall Θ Γ T b t1 t2 x,
    wf t1 0 ->
    wf t2 0 ->
    subset (fv t1) (support Γ) ->
    subset (fv t2) (support Γ) ->
    ~(x ∈ fv b) ->
    ~(x ∈ fv T) ->
    ~(x ∈ fv_context Γ) ->
    ~(x ∈ Θ) ->
    is_erased_term b ->
    is_erased_term t1 ->
    is_erased_term t2 ->
    [ Θ; Γ ⊨ b : T_bool ] ->
    [ Θ; (x, T_equiv b ttrue) :: Γ ⊨ t1 : T ] ->
    [ Θ; (x, T_equiv b tfalse) :: Γ ⊨ t2 : T ] ->
    [ Θ; Γ ⊨ ite b t1 t2 : T ].
Proof.
  intros; unfold open_reducible; steps.

  unfold open_reducible in *; apply reducible_ite; repeat step || t_termlist;
    eauto with wf;
    eauto using subset_same with fv;
    eauto with erased.

  - unshelve epose proof (H11 _ ((x, uu) :: lterms) _ _ _);
      repeat step || apply SatCons || list_utils || simp_red || t_substitutions.
  - unshelve epose proof (H12 _ ((x, uu) :: lterms) _ _ _);
      repeat step || apply SatCons || list_utils || simp_red || t_substitutions.
Qed.


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

(** Common subexpression elimination over RTL.  This optimization
  proceeds by value numbering over extended basic blocks. *)

Require Import Coqlib.
Require Import Maps.
Require Import Errors.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import RTLtyping.
Require Import Kildall.
Require Import CombineOp.

(** * Value numbering *)

(** The idea behind value numbering algorithms is to associate
  abstract identifiers (``value numbers'') to the contents of registers
  at various program points, and record equations between these
  identifiers.  For instance, consider the instruction
  [r1 = add(r2, r3)] and assume that [r2] and [r3] are mapped
  to abstract identifiers [x] and [y] respectively at the program
  point just before this instruction.  At the program point just after,
  we can add the equation [z = add(x, y)] and associate [r1] with [z],
  where [z] is a fresh abstract identifier.  However, if we already
  knew an equation [u = add(x, y)], we can preferably add no equation
  and just associate [r1] with [u].  If there exists a register [r4]
  mapped with [u] at this point, we can then replace the instruction
  [r1 = add(r2, r3)] by a move instruction [r1 = r4], therefore eliminating
  a common subexpression and reusing the result of an earlier addition.

  Abstract identifiers / value numbers are represented by positive integers.
  Equations are of the form [valnum = rhs], where the right-hand sides
  [rhs] are either arithmetic operations or memory loads. *)

(*
Definition valnum := positive.

Inductive rhs : Type :=
  | Op: operation -> list valnum -> rhs
  | Load: memory_chunk -> addressing -> list valnum -> rhs.
*)

Definition eq_valnum: forall (x y: valnum), {x=y}+{x<>y} := peq.

Definition eq_list_valnum (x y: list valnum) : {x=y}+{x<>y}.
Proof. decide equality. apply eq_valnum. Defined.

Definition eq_rhs (x y: rhs) : {x=y}+{x<>y}.
Proof.
  generalize Int.eq_dec; intro.
  generalize Float.eq_dec; intro.
  generalize eq_operation; intro.
  generalize eq_addressing; intro.
  assert (forall (x y: memory_chunk), {x=y}+{x<>y}). decide equality.
  generalize eq_valnum; intro.
  generalize eq_list_valnum; intro.
  decide equality.
Defined.

(** A value numbering is a collection of equations between value numbers
  plus a partial map from registers to value numbers.  Additionally,
  we maintain the next unused value number, so as to easily generate
  fresh value numbers. *)

Record numbering : Type := mknumbering {
  num_next: valnum;                  (**r first unused value number *)
  num_eqs: list (valnum * rhs);       (**r valid equations *)
  num_reg: PTree.t valnum;           (**r mapping register to valnum *)
  num_val: PMap.t (list reg)         (**r reverse mapping valnum to regs containing it *)
}.

Definition empty_numbering :=
  mknumbering 1%positive nil (PTree.empty valnum) (PMap.init nil).

(** [valnum_reg n r] returns the value number for the contents of
  register [r].  If none exists, a fresh value number is returned
  and associated with register [r].  The possibly updated numbering
  is also returned.  [valnum_regs] is similar, but for a list of
  registers. *)

Definition valnum_reg (n: numbering) (r: reg) : numbering * valnum :=
  match PTree.get r n.(num_reg) with
  | Some v => (n, v)
  | None   =>
      let v := n.(num_next) in
      (mknumbering (Psucc v)
                   n.(num_eqs)
                   (PTree.set r v n.(num_reg))
                   (PMap.set v (r :: nil) n.(num_val)),
       v)
  end.

Fixpoint valnum_regs (n: numbering) (rl: list reg)
                     {struct rl} : numbering * list valnum :=
  match rl with
  | nil =>
      (n, nil)
  | r1 :: rs =>
      let (n1, v1) := valnum_reg n r1 in
      let (ns, vs) := valnum_regs n1 rs in
      (ns, v1 :: vs)
  end.

(** [find_valnum_rhs rhs eqs] searches the list of equations [eqs]
  for an equation of the form [vn = rhs] for some value number [vn].
  If found, [Some vn] is returned, otherwise [None] is returned. *)

Fixpoint find_valnum_rhs (r: rhs) (eqs: list (valnum * rhs))
                         {struct eqs} : option valnum :=
  match eqs with
  | nil => None
  | (v, r') :: eqs1 =>
      if eq_rhs r r' then Some v else find_valnum_rhs r eqs1
  end.

(** [find_valnum_num vn eqs] searches the list of equations [eqs]
  for an equation of the form [vn = rhs] for some equation [rhs].
  If found, [Some rhs] is returned, otherwise [None] is returned. *)

Fixpoint find_valnum_num (v: valnum) (eqs: list (valnum * rhs))
                         {struct eqs} : option rhs :=
  match eqs with
  | nil => None
  | (v', r') :: eqs1 =>
      if peq v v' then Some r' else find_valnum_num v eqs1
  end.

(** Update the [num_val] mapping prior to a redefinition of register [r]. *)

Definition forget_reg (n: numbering) (rd: reg) : PMap.t (list reg) :=
  match PTree.get rd n.(num_reg) with
  | None => n.(num_val)
  | Some v => PMap.set v (List.remove peq rd (PMap.get v n.(num_val))) n.(num_val)
  end.

Definition update_reg (n: numbering) (rd: reg) (vn: valnum) : PMap.t (list reg) :=
  let nv := forget_reg n rd in PMap.set vn (rd :: PMap.get vn nv) nv.

(** [add_rhs n rd rhs] updates the value numbering [n] to reflect
  the computation of the operation or load represented by [rhs]
  and the storing of the result in register [rd].  If an equation
  [vn = rhs] is known, register [rd] is set to [vn].  Otherwise,
  a fresh value number [vn] is generated and associated with [rd],
  and the equation [vn = rhs] is added. *)

Definition add_rhs (n: numbering) (rd: reg) (rh: rhs) : numbering :=
  match find_valnum_rhs rh n.(num_eqs) with
  | Some vres =>
      mknumbering n.(num_next) n.(num_eqs)
                  (PTree.set rd vres n.(num_reg))
                  (update_reg n rd vres)
  | None =>
      mknumbering (Psucc n.(num_next))
                  ((n.(num_next), rh) :: n.(num_eqs))
                  (PTree.set rd n.(num_next) n.(num_reg))
                  (update_reg n rd n.(num_next))
  end.

(** [add_op n rd op rs] specializes [add_rhs] for the case of an
  arithmetic operation.  The right-hand side corresponding to [op]
  and the value numbers for the argument registers [rs] is built
  and added to [n] as described in [add_rhs].

  If [op] is a move instruction, we simply assign the value number of
  the source register to the destination register, since we know that
  the source and destination registers have exactly the same value.
  This enables more common subexpressions to be recognized. For instance:
<<
     z = add(x, y);  u = x; v = add(u, y);
>>
  Since [u] and [x] have the same value number, the second [add]
  is recognized as computing the same result as the first [add],
  and therefore [u] and [z] have the same value number. *)

Definition add_op (n: numbering) (rd: reg) (op: operation) (rs: list reg) :=
  match is_move_operation op rs with
  | Some r =>
      let (n1, v) := valnum_reg n r in
      mknumbering n1.(num_next) n1.(num_eqs)
                 (PTree.set rd v n1.(num_reg)) (update_reg n1 rd v)
  | None =>
      let (n1, vs) := valnum_regs n rs in
      add_rhs n1 rd (Op op vs)
  end.

(** [add_load n rd chunk addr rs] specializes [add_rhs] for the case of a
  memory load.  The right-hand side corresponding to [chunk], [addr]
  and the value numbers for the argument registers [rs] is built
  and added to [n] as described in [add_rhs]. *)

Definition add_load (n: numbering) (rd: reg)
                    (chunk: memory_chunk) (addr: addressing)
                    (rs: list reg) :=
  let (n1, vs) := valnum_regs n rs in
  add_rhs n1 rd (Load chunk addr vs).

(** [add_unknown n rd] returns a numbering where [rd] is mapped to a
   fresh value number, and no equations are added.  This is useful
   to model instructions with unpredictable results such as [Ibuiltin]. *)

Definition add_unknown (n: numbering) (rd: reg) :=
  mknumbering (Psucc n.(num_next))
              n.(num_eqs)
              (PTree.set rd n.(num_next) n.(num_reg))
              (forget_reg n rd).

(** [kill_equations pred n] remove all equations satisfying predicate [pred]. *)

Fixpoint kill_eqs (pred: rhs -> bool) (eqs: list (valnum * rhs)) : list (valnum * rhs) :=
  match eqs with
  | nil => nil
  | eq :: rem => if pred (snd eq) then kill_eqs pred rem else eq :: kill_eqs pred rem
  end.

Definition kill_equations (pred: rhs -> bool) (n: numbering) : numbering :=
  mknumbering n.(num_next)
              (kill_eqs pred n.(num_eqs))
              n.(num_reg) n.(num_val).

(** [kill_loads n] removes all equations involving memory loads,
  as well as those involving memory-dependent operators.
  It is used to reflect the effect of a builtin operation, which can
  change memory in unpredictable ways and potentially invalidate all such equations. *)

Definition filter_loads (r: rhs) : bool :=
  match r with
  | Op op _ => op_depends_on_memory op
  | Load _ _ _ => true
  end.

Definition kill_loads (n: numbering) : numbering :=
  kill_equations filter_loads n.

(** [add_store n chunk addr rargs rsrc] updates the numbering [n] to reflect
  the effect of a store instruction [Istore chunk addr rargs rsrc].
  Equations involving the memory state are removed from [n], unless we
  can prove that the store does not invalidate them.
  Then, an equations [rsrc = Load chunk addr rargs] is added to reflect
  the known content of the stored memory area, but only if [chunk] is
  a "full-size" quantity ([Mint32] or [Mfloat64] or [Mint64]). *)

Definition filter_after_store (chunk: memory_chunk) (addr: addressing) (vl: list valnum) (r: rhs) : bool :=
  match r with
  | Op op vl' => op_depends_on_memory op
  | Load chunk' addr' vl' =>
      negb(eq_list_valnum vl vl' && addressing_separated chunk addr chunk' addr')
  end.

Definition add_store (n: numbering) (chunk: memory_chunk) (addr: addressing)
                                   (rargs: list reg) (rsrc: reg) : numbering :=
  let (n1, vargs) := valnum_regs n rargs in
  let n2 := kill_equations (filter_after_store chunk addr vargs) n1 in
  match chunk with
  | Mint32 | Mint64 | Mfloat64 | Mfloat64al32 => add_rhs n2 rsrc (Load chunk addr vargs)
  | _ => n2
  end.

(** [reg_valnum n vn] returns a register that is mapped to value number
    [vn], or [None] if no such register exists. *)

Definition reg_valnum (n: numbering) (vn: valnum) : option reg :=
  match PMap.get vn n.(num_val) with
  | nil => None
  | r :: rs => Some r
  end.

Fixpoint regs_valnums (n: numbering) (vl: list valnum) : option (list reg) :=
  match vl with
  | nil => Some nil
  | v1 :: vs =>
      match reg_valnum n v1, regs_valnums n vs with
      | Some r1, Some rs => Some (r1 :: rs)
      | _, _ => None
      end
  end.

(** [find_rhs] return a register that already holds the result of the given arithmetic
    operation or memory load, according to the given numbering.
    [None] is returned if no such register exists. *)

Definition find_rhs (n: numbering) (rh: rhs) : option reg :=
  match find_valnum_rhs rh n.(num_eqs) with
  | None => None
  | Some vres => reg_valnum n vres
  end.

(** Experimental: take advantage of known equations to select more efficient
  forms of operations, addressing modes, and conditions. *)

Section REDUCE.

Variable A: Type.
Variable f: (valnum -> option rhs) -> A -> list valnum -> option (A * list valnum).
Variable n: numbering.

Fixpoint reduce_rec (niter: nat) (op: A) (args: list valnum) : option(A * list reg) :=
  match niter with
  | O => None
  | S niter' =>
      match f (fun v => find_valnum_num v n.(num_eqs)) op args with
      | None => None
      | Some(op', args') =>
          match reduce_rec niter' op' args' with
          | None =>
              match regs_valnums n args' with Some rl => Some(op', rl) | None => None end
          | Some _ as res =>
              res
          end
      end
  end.

Definition reduce (op: A) (rl: list reg) (vl: list valnum) : A * list reg :=
  match reduce_rec 4%nat op vl with
  | None     => (op, rl)
  | Some res => res
  end.

End REDUCE.

(** * The static analysis *)

(** We now define a notion of satisfiability of a numbering.  This semantic
  notion plays a central role in the correctness proof (see [CSEproof]),
  but is defined here because we need it to define the ordering over
  numberings used in the static analysis.

  A numbering is satisfiable in a given register environment and memory
  state if there exists a valuation, mapping value numbers to actual values,
  that validates both the equations and the association of registers
  to value numbers. *)

Definition equation_holds
     (valuation: valnum -> val)
     (ge: genv) (sp: val) (m: mem)
     (vres: valnum) (rh: rhs) : Prop :=
  match rh with
  | Op op vl =>
      eval_operation ge sp op (List.map valuation vl) m =
      Some (valuation vres)
  | Load chunk addr vl =>
      exists a,
      eval_addressing ge sp addr (List.map valuation vl) = Some a /\
      Mem.loadv chunk m a = Some (valuation vres)
  end.

Definition numbering_holds
   (valuation: valnum -> val)
   (ge: genv) (sp: val) (rs: regset) (m: mem) (n: numbering) : Prop :=
     (forall vn rh,
       In (vn, rh) n.(num_eqs) ->
       equation_holds valuation ge sp m vn rh)
  /\ (forall r vn,
       PTree.get r n.(num_reg) = Some vn -> rs#r = valuation vn).

Definition numbering_satisfiable
   (ge: genv) (sp: val) (rs: regset) (m: mem) (n: numbering) : Prop :=
  exists valuation, numbering_holds valuation ge sp rs m n.

Lemma empty_numbering_satisfiable:
  forall ge sp rs m, numbering_satisfiable ge sp rs m empty_numbering.
Proof.
  intros; red.
  exists (fun (vn: valnum) => Vundef). split; simpl; intros.
  elim H.
  rewrite PTree.gempty in H. discriminate.
Qed.

(** We now equip the type [numbering] with a partial order and a greatest
  element.  The partial order is based on entailment: [n1] is greater
  than [n2] if [n1] is satisfiable whenever [n2] is.  The greatest element
  is, of course, the empty numbering (no equations). *)

Module Numbering.
  Definition t := numbering.
  Definition ge (n1 n2: numbering) : Prop :=
    forall ge sp rs m,
    numbering_satisfiable ge sp rs m n2 ->
    numbering_satisfiable ge sp rs m n1.
  Definition top := empty_numbering.
  Lemma top_ge: forall x, ge top x.
  Proof.
    intros; red; intros. unfold top. apply empty_numbering_satisfiable.
  Qed.
  Lemma refl_ge: forall x, ge x x.
  Proof.
    intros; red; auto.
  Qed.
End Numbering.

(** We reuse the solver for forward dataflow inequations based on
  propagation over extended basic blocks defined in library [Kildall]. *)

Module Solver := BBlock_solver(Numbering).

(** The transfer function for the dataflow analysis returns the numbering
  ``after'' execution of the instruction at [pc], as a function of the
  numbering ``before''.  For [Iop] and [Iload] instructions, we add
  equations or reuse existing value numbers as described for
  [add_op] and [add_load].  For [Istore] instructions, we forget
  all equations involving memory loads.  For [Icall] instructions,
  we could simply associate a fresh, unconstrained by equations value number
  to the result register.  However, it is often undesirable to eliminate
  common subexpressions across a function call (there is a risk of
  increasing too much the register pressure across the call), so we
  just forget all equations and start afresh with an empty numbering.
  Finally, for instructions that modify neither registers nor
  the memory, we keep the numbering unchanged.

  For builtin invocations [Ibuiltin], we have three strategies:
- Forget all equations.  This is appropriate for builtins that can be
  turned into function calls ([EF_external], [EF_malloc], [EF_free]).
- Forget equations involving loads but keep equations over registers.
  This is appropriate for builtins that modify memory, e.g. [EF_memcpy].
- Keep all equations, taking advantage of the fact that neither memory
  nor registers are modified.  This is appropriate for annotations,
  for inlined builtin functions, and for volatile loads.
*)

Definition transfer (f: function) (pc: node) (before: numbering) :=
  match f.(fn_code)!pc with
  | None => before
  | Some i =>
      match i with
      | Inop s =>
          before
      | Iop op args res s =>
          add_op before res op args
      | Iload chunk addr args dst s =>
          add_load before dst chunk addr args
      | Istore chunk addr args src s =>
          add_store before chunk addr args src
      | Icall sig ros args res s =>
          empty_numbering
      | Itailcall sig ros args =>
          empty_numbering
      | Ibuiltin ef args res s =>
          match ef with
          | EF_external _ _ | EF_malloc | EF_free | EF_inline_asm _ =>
              empty_numbering
          | EF_vstore _ | EF_vstore_global _ _ _ | EF_memcpy _ _ =>
              add_unknown (kill_loads before) res
          | EF_builtin _ _ | EF_vload _ | EF_vload_global _ _ _
          | EF_annot _ _ | EF_annot_val _ _ =>
              add_unknown before res
          end
      | Icond cond args ifso ifnot =>
          before
      | Ijumptable arg tbl =>
          before
      | Ireturn optarg =>
          before
      end
  end.

(** The static analysis solves the dataflow inequations implied
  by the [transfer] function using the ``extended basic block'' solver,
  which produces sub-optimal solutions quickly.  The result is
  a mapping from program points to numberings. *)

Definition analyze (f: RTL.function): option (PMap.t numbering) :=
  Solver.fixpoint (successors f) (transfer f) f.(fn_entrypoint).

(** * Code transformation *)

(** The code transformation is performed instruction by instruction.
  [Iload] instructions and non-trivial [Iop] instructions are turned
  into move instructions if their result is already available in a
  register, as indicated by the numbering inferred at that program point.

  Some operations are so cheap to compute that it is generally not
  worth reusing their results.  These operations are detected by the
  function [is_trivial_op] in module [Op]. *)

Definition transf_instr (n: numbering) (instr: instruction) :=
  match instr with
  | Iop op args res s =>
      if is_trivial_op op then instr else
        let (n1, vl) := valnum_regs n args in
        match find_rhs n1 (Op op vl) with
        | Some r =>
            Iop Omove (r :: nil) res s
        | None =>
            let (op', args') := reduce _ combine_op n1 op args vl in
            Iop op' args' res s
        end
  | Iload chunk addr args dst s =>
      let (n1, vl) := valnum_regs n args in
      match find_rhs n1 (Load chunk addr vl) with
      | Some r =>
          Iop Omove (r :: nil) dst s
      | None =>
          let (addr', args') := reduce _ combine_addr n1 addr args vl in
          Iload chunk addr' args' dst s
      end
  | Istore chunk addr args src s =>
      let (n1, vl) := valnum_regs n args in
      let (addr', args') := reduce _ combine_addr n1 addr args vl in
      Istore chunk addr' args' src s
  | Icond cond args s1 s2 =>
      let (n1, vl) := valnum_regs n args in
      let (cond', args') := reduce _ combine_cond n1 cond args vl in
      Icond cond' args' s1 s2
  | _ =>
      instr
  end.

Definition transf_code (approxs: PMap.t numbering) (instrs: code) : code :=
  PTree.map (fun pc instr => transf_instr approxs!!pc instr) instrs.

Definition transf_function (f: function) : res function :=
  match type_function f with
  | Error msg => Error msg
  | OK tyenv =>
      match analyze f with
      | None => Error (msg "CSE failure")
      | Some approxs =>
          OK(mkfunction
               f.(fn_sig)
               f.(fn_params)
               f.(fn_stacksize)
               (transf_code approxs f.(fn_code))
               f.(fn_entrypoint))
      end
  end.

Definition transf_fundef (f: fundef) : res fundef :=
  AST.transf_partial_fundef transf_function f.

Definition transf_program (p: program) : res program :=
  transform_partial_program transf_fundef p.


Require Import OrderedType.
Require Import CoqlibC.
Require Import Maps.
Require Import Ordered.
Require Import AST.
Require Import Values.
Require Export Machregs.
(** newly added **)
Require Export Locations.
Require Import Conventions Integers Memory.
Require Import List.

Set Implicit Arguments.

Lemma Loc_not_in_notin_R
      r locs
      (NOTIN: ~ In (R r) locs):
    <<NOTIN: Loc.notin (R r) locs>>.
Proof. red. ginduction locs; ii; ss. esplits; eauto. destruct a; ss. ii; clarify. eauto. Qed.

Lemma typealign_divide_8: forall ty,
    <<DIV: (4 * typealign ty | 8)>>.
Proof.
  i. red. change 8 with (4 * 2). eapply Z.mul_divide_mono_l.
  destruct ty; ss; try reflexivity; try apply Z.divide_1_l.
Qed.

Definition locset := Locmap.t.

Local Opaque Z.mul Z.add.
Local Opaque list_nth_z.

Definition is_one A (ap: rpair A): bool :=
  match ap with
  | One _ => true
  | Twolong _ _ => false
  end.

(* Note: this is hacking for 64bit. It just simplifies proof, we don't exploit anything weird *)
Lemma loc_arguments_one:
  forall sg lp (IN: In lp (loc_arguments sg)), <<ONE: is_one lp>>.
Proof.
  destruct sg; ss. unfold loc_arguments in *. ss. des_ifs. clear_tac.
  generalize 0 at 1 as ir. generalize 0 at 1 as fr. generalize 0 at 1 as ofs.
  ginduction sig_args; ii; ss.
  - des_ifs; repeat (des; ss; clarify); eapply IHsig_args; eauto.
Qed.

Lemma loc_result_one: forall sg, exists mr_res, <<ONE: loc_result sg = One mr_res>>.
Proof. i. compute. des_ifs; eauto. Qed.

Lemma Loc_cons_right_disjoint
      xs0 xs1 x
      (DISJ: Loc.disjoint xs0 xs1)
      (NOTIN: Loc.notin x xs0):
    <<DISJ: Loc.disjoint xs0 (x :: xs1)>>.
Proof.
  ii; ss. des; ss; clarify; eauto.
  apply Loc.diff_sym. eapply Loc.in_notin_diff; eauto.
Qed.

Lemma disjoint_concat l1 l2 x:
    Loc.disjoint (l1++[x]) l2 -> Loc.disjoint l1 l2.
Proof. unfold Loc.disjoint. i. eapply H; eauto. eapply in_or_app. left. eauto. Qed.

Lemma norepet_nth_notin l n m
      (NOREPET: Loc.norepet l)
      (NTH: list_nth_z l (Z.of_nat n) = Some m):
    Loc.notin m (firstn n l).
Proof.
  ginduction l; i; ss. inv NOREPET. destruct n.
  { inv NTH. ss. }
  Local Transparent list_nth_z. unfold list_nth_z in NTH. fold list_nth_z in NTH. Local Opaque list_nth_z. des_ifs.
  replace (Z.pred (Z.of_nat (Datatypes.S n))) with (Z.of_nat n) in *; try nia.
  rewrite firstn_cons. ss. esplits; et. eapply Loc.diff_sym. eapply Loc.in_notin_diff; et. eapply list_nth_z_in; et.
Qed.

Lemma disjoint_app_inv: forall l1 l2 l3,
    Loc.disjoint l1 (l2 ++ l3) -> Loc.disjoint l1 l2 /\ Loc.disjoint l1 l3.
Proof.
  i. ginduction l2; ii; ss.
  { esplits; et. ss. }
  split.
  - ii. ss. eapply H; et. ss. des; clarify; et. right. rewrite in_app_iff. et.
  - apply Loc.disjoint_cons_right in H. eapply IHl2; et.
Qed.

Lemma notin_regs_of_rpairs
      ofs tys ir fr ofs2 T
      (LT:ofs + 2 <= ofs2):
    Loc.notin (S Outgoing ofs T) (regs_of_rpairs (loc_arguments_64 tys ir fr ofs2)).
Proof.
  ginduction tys; ss; i.
  des_ifs; destruct T; econs; ss; et; try nia; eapply IHtys; try nia.
Qed.

Lemma loc_arguments_norepet_aux
      tys (ir fr ofs: Z) locs
      (LOCS: (regs_of_rpairs (loc_arguments_64 tys ir fr ofs)) = locs):
    (<<NOREP: Loc.norepet locs>>)
    /\ (<<NOTINIR: Loc.disjoint (map R (List.firstn (Z.to_nat ir) int_param_regs)) locs>>)
    /\ (<<NOTINFR: Loc.disjoint (map R (List.firstn (Z.to_nat fr) float_param_regs)) locs>>).
Proof.
  ginduction tys; ii; clarify.
  { esplits; ii; ss; econs. }
  assert(TTT: Loc.disjoint (map R int_param_regs) (map R float_param_regs)).
  { ii; ss. des; subst; ss. }
  destruct (classic (a = Tfloat \/ a = Tsingle)).
  { assert(loc_arguments_64 (a :: tys) ir fr ofs =
           match list_nth_z float_param_regs fr with
           | Some freg => One (R freg) :: loc_arguments_64 tys ir (fr + 1) ofs
           | None => One (S Outgoing ofs a) :: loc_arguments_64 tys ir fr (ofs + 2)
           end).
    { desH H; subst; ss. }
    rewrite H0. clear H H0. des_ifs.
    - specialize (IHtys ir (fr + 1) ofs _ eq_refl); des; ss.
      esplits; eauto.
      + econs; eauto. eapply Loc.disjoint_notin; try apply NOTINFR. eapply in_map.
        eapply list_nth_z_in. eapply list_nth_z_firstn; et.
      + eapply Loc_cons_right_disjoint; eauto.
        { clear - Heq TTT. eapply Loc.disjoint_notin; cycle 1.
          - eapply list_nth_z_in. eapply list_nth_z_map; et.
          - eapply Loc.disjoint_sym in TTT. rewrite map_firstn.
            erewrite <- firstn_skipn in TTT. eapply disjoint_app_inv in TTT. des; et.
        }
      + eapply Loc_cons_right_disjoint; eauto.
        { exploit list_nth_z_range; et. intro RANGE.
          destruct fr; try xomega; ss.
          exploit (firstn_S float_param_regs). i; desH H.
          - rewrite <- H0. replace (Pos.to_nat p + 1)%nat with (Pos.to_nat (p + 1)); try nia. eauto.
          - replace (Z.to_nat (Z.pos p + 1)) with (Pos.to_nat p + 1)%nat in *; cycle 1.
            { clear. rewrite Z2Nat.inj_add; try nia. ss. }
            rewrite H0 in NOTINFR. rewrite list_append_map in NOTINFR; ss. eapply disjoint_concat; et.
        }
        { clear - Heq. rewrite map_firstn. eapply norepet_nth_notin; try do 9 (econs; ss).
          eapply list_nth_z_map; et. rewrite Z2Nat.id; et. eapply list_nth_z_range; et.
        }
    - specialize (IHtys ir fr (ofs + 2) _ eq_refl); des; ss.
      esplits; eauto;
        try (eapply Loc_cons_right_disjoint; eauto;
             eapply Loc.disjoint_notin with (l1 := [_]); ss; et; ii; rewrite in_map_iff in *; ss; des; clarify).
      econs; eauto. eapply notin_regs_of_rpairs. nia.
  }
  { assert(a = Tint \/ a = Tlong \/ a = Tany32 \/ a = Tany64).
    { eapply not_or_and in H. des. destruct a; des_ifs; et. }
    assert(loc_arguments_64 (a :: tys) ir fr ofs =
           match list_nth_z int_param_regs ir with
           | Some ireg => One (R ireg) :: loc_arguments_64 tys (ir + 1) fr ofs
           | None => One (S Outgoing ofs a) :: loc_arguments_64 tys ir fr (ofs + 2)
           end).
    { desH H0; subst; ss. }
    rewrite H1. clear H H0 H1. des_ifs.
    - specialize (IHtys (ir + 1) fr ofs _ eq_refl); des; ss.
      esplits; eauto.
      + econs; eauto. eapply Loc.disjoint_notin; try apply NOTINIR. eapply in_map.
        eapply list_nth_z_in. eapply list_nth_z_firstn; et.
      + eapply Loc_cons_right_disjoint; eauto.
        { exploit list_nth_z_range; et. intro RANGE.
          destruct ir; try xomega; ss.
          exploit (firstn_S int_param_regs). i; desH H.
          - rewrite <- H0. replace (Pos.to_nat p + 1)%nat with (Pos.to_nat (p + 1)); try nia. eauto.
          - replace (Z.to_nat (Z.pos p + 1)) with (Pos.to_nat p + 1)%nat in *; cycle 1.
            { clear. rewrite Z2Nat.inj_add; try nia. ss. }
            rewrite H0 in NOTINIR. rewrite list_append_map in NOTINIR; ss. eapply disjoint_concat; et.
        }
        { clear - Heq. rewrite map_firstn. eapply norepet_nth_notin; try do 7 (econs; ss).
          eapply list_nth_z_map; et. rewrite Z2Nat.id; et. eapply list_nth_z_range; et.
        }
      + eapply Loc_cons_right_disjoint; eauto.
        { clear - Heq TTT. eapply Loc.disjoint_notin; cycle 1.
          - eapply list_nth_z_in. eapply list_nth_z_map; et.
          - rewrite map_firstn. erewrite <- firstn_skipn in TTT. eapply disjoint_app_inv in TTT. des; et.
        }
    - specialize (IHtys ir fr (ofs + 2) _ eq_refl); des; ss.
      esplits; eauto;
        try (eapply Loc_cons_right_disjoint; eauto;
             eapply Loc.disjoint_notin with (l1 := [_]); ss; et; ii; rewrite in_map_iff in *; ss; des; clarify).
      econs; eauto. eapply notin_regs_of_rpairs. nia.
  }
Qed.

Lemma loc_arguments_norepet: forall sg, Loc.norepet (regs_of_rpairs (loc_arguments sg)).
Proof.
  i. unfold loc_arguments. des_ifs.
  generalize (loc_arguments_norepet_aux (sig_args sg) 0 0 0). i. specialize (H _ eq_refl). des. ss.
Qed.

Lemma loc_norepet_app l0 l1
      (NOREPEAT: Loc.norepet (l0 ++ l1)):
    Loc.norepet l1.
Proof. induction l0; ss. inv NOREPEAT. eauto. Qed.

Lemma loc_notin_not_in mr locs:
  Loc.notin (R mr) locs <-> ~ In (R mr) locs.
Proof.
  induction locs; ss. split; ii; des; des_ifs.
  - eapply IHlocs; eauto.
  - eapply IHlocs; eauto.
  - apply not_or_and in H. des. split; auto. ii. clarify.
  - apply not_or_and in H. des. split; auto.
Qed.

Lemma in_one_in_rpair l (r: loc)
      (IN: In (One r) l):
    In r (regs_of_rpairs l).
Proof.
  induction l; ss; des; clarify.
  - destruct r; ss; eauto.
  - eapply in_or_app; eauto.
Qed.

Lemma loc_arguments_ofs_bounded
      sg lo
      (SZ: 0 <= lo /\ lo + 4 * size_arguments sg <= Ptrofs.max_unsigned)
      ofs ty
      (IN: In (One (S Outgoing ofs ty)) (loc_arguments sg)):
  0 <= lo + 4 * ofs <= Ptrofs.max_unsigned.
Proof.
  hexploit loc_arguments_bounded.
  - instantiate (1:=sg). instantiate (1:=ty). instantiate (1:=ofs).
    revert ofs ty IN. induction (loc_arguments sg); ss; i.
    des; clarify; ss; eauto. eapply in_app_iff. right. eapply IHl; eauto.
  - i. split.
    + hexploit (loc_arguments_acceptable sg); eauto. intros ACCP. inv ACCP. lia.
    + destruct ty; ss; lia.
Qed.

  Lemma sig_args_length sg
  :
    Datatypes.length (sig_args sg) = Datatypes.length (loc_arguments sg).
Proof.
  unfold loc_arguments in *. des_ifs.
  generalize 0 at 1. generalize 0 at 1. generalize 0 at 1.
  induction (sig_args sg); ss; i. des_ifs; ss; f_equal; eauto.
Qed.

Lemma Val_has_type_list_length sg vs
      (TYP: Val.has_type_list vs (sig_args sg)):
    Datatypes.length vs = Datatypes.length (loc_arguments sg).
Proof.
  rewrite <- sig_args_length.
  revert vs TYP. induction (sig_args sg); ss; i; destruct vs; ss.
  des. f_equal; eauto.
Qed.

Ltac _locmap_tac :=
  try (first[rewrite Locmap.gss; ss; check_safe|rewrite Locmap.gso; ss]);
  try match goal with
      | [H: Loc.notin _ (_ :: _) |- _] => inv H
      | [H: Loc.norepet (_ :: _) |- _] => inv H
      | [ |- Loc.diff _ _] => by (eapply Loc.in_notin_diff; eauto)
      | [H: Loc.diff ?A ?B |- Loc.diff ?B ?A] => apply Loc.diff_sym; assumption
      | [H: R ?x <> R ?y |- _] =>
        tryif exists_prop (x <> y)
        then idtac
        else assert(x <> y) by (ii; clarify; ss)
      end;
  des_safe;
  idtac.

Local Opaque Loc.diff.
Ltac locmap_tac := repeat _locmap_tac.

Definition locmap_put (l: loc) (v: val) (ls: locset): locset :=
  fun loc => if Loc.eq loc l then v else ls loc.

Hint Unfold locmap_put.

Fixpoint fill_arguments (ls0: locset) (args: list val) (locs: list (rpair loc)): option locset :=
  match args, locs with
  | [], [] => Some ls0
  | arg :: args, loc :: locs =>
    match fill_arguments ls0 args locs with
    | Some ls1 =>
      match loc with
      | One loc => Some (locmap_put loc arg ls1)
      | Twolong hi lo => (* not used *)
        Some (Locmap.set lo (Val.loword arg) (Locmap.set hi (Val.hiword arg) ls1))
      end
    | None => None
    end
  | _, _ => None
  end.

Lemma fill_arguments_progress
      ls0 args locs
      (LEN: length args = length locs):
      exists ls1, <<LS: fill_arguments ls0 args locs =Some ls1>>.
Proof.
  ginduction args; ii; destruct locs; ss.
  - esplits; eauto.
  - exploit IHargs; eauto. i; des. rewrite LS. des_ifs; esplits; eauto.
Qed.

Lemma fill_arguments_spec
      vs sg locs ls0 ls1
      (LOCS: locs = loc_arguments sg)
      (FILL: fill_arguments ls0 vs locs = Some ls1):
    <<FILL: vs = map (fun p => Locmap.getpair p ls1) locs>> /\
    <<OUT: forall loc
             (* (NOTIN: Loc.notin loc (regs_of_rpairs locs)) *)
             (NOTIN: ~ In loc (regs_of_rpairs locs)),
      ls1 loc = ls0 loc>>.
Proof.
  subst.
  assert(ONES: forall lp, In lp (loc_arguments sg) -> is_one lp).
  { i. eapply loc_arguments_one; eauto. }
  assert(NOREPT: Loc.norepet (regs_of_rpairs (loc_arguments sg))).
  { apply loc_arguments_norepet. }
  abstr (loc_arguments sg) locs. clear_tac.
  ginduction locs; ii; destruct vs; ss.
  { clarify. }
  des_ifs_safe.
  exploit IHlocs; eauto. { eapply loc_norepet_app; eauto. } i; des.
  spc ONES. exploit ONES; eauto. i; des; ss. des_ifs; ss. clear_tac.
  split; ss.
  - red. f_equal; ss.
    + u. des_ifs.
    + clear - NOREPT. inv NOREPT. induction locs; ss.
      f_equal.
      * unfold locmap_put. destruct a; ss; des; apply_all_once Loc.diff_not_eq; des_ifs.
      * eapply loc_norepet_app in H2. eapply IHlocs; eauto. destruct a; inv H1; try inv H0; eauto.
  - ii; des. u. des_ifs.
    + contradict NOTIN. eauto.
    + erewrite OUT; eauto.
Qed.

Definition extcall_args_reg (mr: mreg) (sg: signature):
  {In (R mr) (regs_of_rpairs (loc_arguments sg))} +
  {~ In (R mr) (regs_of_rpairs (loc_arguments sg))}.
Proof.
  generalize (regs_of_rpairs (loc_arguments sg)). induction l.
  - ss. tauto.
  - ss. inv IHl; [tauto|]. destruct a.
    + destruct (mreg_eq r mr); [clarify; eauto|]. right. intros []; clarify.
    + right. intros []; clarify.
Qed.

Lemma arguments_loc sg sl delta ty
      (IN: In (S sl delta ty) (regs_of_rpairs (loc_arguments sg))):
    sl = Outgoing /\
    0 <= delta /\
    4 * delta + size_chunk (chunk_of_type ty) <= 4 * size_arguments sg.
Proof.
  generalize (loc_arguments_acceptable_2 _ _ IN). i. ss. des_ifs.
  set (loc_arguments_bounded _ _ _ IN).
  splits; eauto; [omega|]. unfold typesize in *. des_ifs; ss; lia.
Qed.

Lemma regs_of_rpair_In A (l: list (rpair A)):
    (forall r (IN: In (One r) l), In r (regs_of_rpairs l))
    /\ (forall r0 r1 (IN: In (Twolong r0 r1) l),
           In r0 (regs_of_rpairs l) /\ In r1 (regs_of_rpairs l)).
Proof.
  induction l; i; ss; split; i; des; clarify; ss; eauto.
  - eapply in_or_app. eauto.
  - split; eapply in_or_app; right; eapply (IHl0 _ _ IN).
Qed.


From Verdi Require Import
  Verdi
  HandlerMonad
  LabeledNet.

From Coq Require Import
  FSets.FMapList
  Structures.OrderedTypeEx.

Require String.

Module Import NatDict := FMapList.Make(Nat_as_OT).

Set Bullet Behavior "Strict Subproofs".

Section Bank.

  Definition Account := Nat_as_OT.t.
  Definition Account_eq_dec : forall a a' : Account, {a = a'} + {a <> a'}.
    decide equality.
  Defined.

  Definition Value := nat.
  Definition Value_eq_dec : forall v v' : Value, {v = v'} + {v <> v'}.
    decide equality.
  Defined.

  Definition minValue : Value := 5.

  Inductive Name := Agent | Server.
  Definition Name_eq_dec : forall n n' : Name, {n = n'} + {n <> n'}.
    decide equality.
  Defined.

  Inductive ReqMsg :=
  | CreateMsg   : Account -> ReqMsg
  | DepositMsg  : Account -> Value  -> ReqMsg
  | WithdrawMsg : Account -> Value  -> ReqMsg
  | CheckMsg    : Account -> ReqMsg.

  Inductive RespMsg :=
  | FailMsg
  | PassMsg : Account -> Value -> RespMsg.

  Inductive Msg :=
  | req  : ReqMsg  -> Msg
  | resp : RespMsg -> Msg.

  Inductive Input :=
  | Timeout
  | Create   : Account -> Input
  | Deposit  : Account -> Value -> Input
  | Withdraw : Account -> Value -> Input
  | Check    : Account -> Input.
  Definition Input_eq_dec : forall i i' : Input, {i = i'} + {i <> i'}.
    repeat decide equality.
  Defined.

  Inductive Output :=
  | Ignore
  | Failed
  | Passed : Account -> Value -> Output.

  Definition ServerState := NatDict.t Value.
  Inductive  AgentState  := wait | pass | fail.
  Definition AState_eq_dec : forall a a' : AgentState, {a = a'} + {a <> a'}.
    decide equality.
  Defined.

  Inductive State :=
  | agent  : AgentState  -> State
  | server : ServerState -> State.
  Definition InitState (name : Name) : State :=
    match name with
    | Agent  => agent  pass
    | Server => server (NatDict.empty Value)
    end.

  Definition ClientId  := String.string.
  Inductive  NetMsg    := netM : ClientId -> Msg    -> NetMsg.
  Inductive  NetInput  := netI : ClientId -> Input  -> NetInput.
  Inductive  NetOutput := netO : ClientId -> Output -> NetOutput.
  Definition NetMsg_eq_dec : forall m m' : NetMsg, {m = m'} + {m <> m'}.
    repeat decide equality.
  Defined.

  Inductive Label :=
  | Ready
  | Waiting
  | Processed
  | Nop
  | Silent.
  Definition LabeledHandler (s : Type) := GenHandler (Name * NetMsg) s NetOutput Label.

  Definition ServerStateHandler := LabeledHandler ServerState.
  Definition AgentStateHandler := LabeledHandler AgentState.
  Definition StateHandler := LabeledHandler State.

  Definition AgentNetHandler (nm : NetMsg) : AgentStateHandler :=
    state <- get ;;
    let 'netM id m := nm in
    match m with
    | req  _ => ret Nop
    | resp r =>
        if AState_eq_dec wait state then
          match r with
          | FailMsg         => put fail >> write_output (netO id Failed)
          | PassMsg acc val => put pass >> write_output (netO id (Passed acc val))
          end ;; ret Ready
        else ret Ready
    end.

  Definition AgentIOHandler (ni : NetInput) : AgentStateHandler :=
    state <- get ;;
    let 'netI id i := ni in
      if AState_eq_dec wait state
      then ((if Input_eq_dec i Timeout
             then put fail >> (write_output (netO id Failed))
             else (write_output (netO id Ignore))) ;; ret Ready)
      else ((if Input_eq_dec i Timeout then nop else put wait) ;;
            (match i with
             | Timeout          => nop
             | Create   acc     => send (Server, netM id (req (CreateMsg   acc)))
             | Deposit  acc val => send (Server, netM id (req (DepositMsg  acc val)))
             | Withdraw acc val => send (Server, netM id (req (WithdrawMsg acc val)))
             | Check    acc     => send (Server, netM id (req (CheckMsg    acc)))
             end) ;;
             (if Input_eq_dec i Timeout then ret Ready else ret Waiting)).

  Definition ServerNetHandler (nm : NetMsg) : ServerStateHandler :=
    state <- get ;;
    let 'netM id m := nm in
    match m with
    | resp _ => ret Nop
    | req  r =>
        match r with
        | CreateMsg acc =>
            match NatDict.find acc state with
            | None => let val'' := minValue in (
                        put (NatDict.add acc val'' state)
                        >> send (Agent, netM id (resp (PassMsg acc val''))))
            | _    => send (Agent, netM id (resp FailMsg))
            end
        | DepositMsg acc val =>
            match NatDict.find acc state with
            | Some val' => let val'' := val' + val in (
                             put (NatDict.add acc val'' state)
                             >> send (Agent, netM id (resp (PassMsg acc val''))))
            | _            => send (Agent, netM id (resp FailMsg))
            end
        | WithdrawMsg acc val =>
            match NatDict.find acc state with
            | Some val' => if lt_dec (val' - val) minValue
                           then send (Agent, netM id (resp FailMsg))
                           else let val'' := val' - val in (
                                  put (NatDict.add acc val'' state)
                                  >> send (Agent, netM id (resp (PassMsg acc val''))))
            | None      => send (Agent, netM id (resp FailMsg))
            end
        | CheckMsg acc =>
            match NatDict.find acc state with
            | Some val' => send (Agent, netM id (resp (PassMsg acc val')))
            | None      => send (Agent, netM id (resp FailMsg))
            end
        end ;; ret Processed
    end.

  Definition ServerIOHandler (ni : NetInput) : ServerStateHandler := ret Nop.

  Global Instance bank_base_params : BaseParams :=
  {
    data   := State ;
    input  := NetInput ;
    output := NetOutput
  }.

  Definition Nodes : list Name := [Server ; Agent].

  Theorem no_dup_Nodes : NoDup Nodes.
  Proof using.
    unfold Nodes. apply NoDup_cons ; simpl.
    - easy'.
    - apply NoDup_cons.
      + easy.
      + apply NoDup_nil.
  Qed.

  Theorem all_Names_Nodes : forall n : Name, List.In n Nodes.
  Proof using.
    unfold Nodes, List.In. destruct n ; auto.
  Qed.

  Definition NetHandler (dst src : Name) (nm : NetMsg) (s : State) :=
    match (dst , s) with
    | (Agent, agent  astate) =>
        let '(a, b, c, d) := runGenHandler astate (AgentNetHandler nm)
        in (a, b, agent c, d)
    | (Server, server sstate) =>
        let '(a, b, c, d) := runGenHandler sstate (ServerNetHandler nm)
        in (a, b, server c, d)
    | _ => (Nop, [], s, [])
    end.

  Definition IOHandler (n : Name) (ni : NetInput) (s : State) :=
    match (n , s) with
    | (Agent, agent astate) =>
        let '(a, b, c, d) := runGenHandler astate (AgentIOHandler ni)
        in (a, b, agent c, d)
    | (Server, server sstate) =>
        let '(a, b, c, d) := runGenHandler sstate (ServerIOHandler ni)
        in (a, b, server c, d)
    | _ => (Nop, [], s, [])
    end.

  Global Instance bank_labeled_params : LabeledMultiParams bank_base_params :=
  {
    label := Label;
    label_silent := Silent;

    lb_name := Name ;
    lb_name_eq_dec := Name_eq_dec;

    lb_msg := NetMsg ;
    lb_msg_eq_dec := NetMsg_eq_dec;

    lb_nodes := Nodes ;
    lb_no_dup_nodes := no_dup_Nodes ;
    lb_all_names_nodes := all_Names_Nodes;

    lb_init_handlers := InitState ;
    lb_net_handlers := NetHandler ;
    lb_input_handlers := IOHandler
  }.

  Global Instance bank_multi_params : MultiParams bank_base_params :=
    unlabeled_multi_params.

  (* FIXME: X_X *)
  Definition reboot (state : State) : State := state.
  Global Instance bank_failure_params : FailureParams _ :=
  {
    reboot := reboot
  }.

End Bank.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable p_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable goal_ : Prop.
Variable dom_ : Universe -> Prop.

Variable a9_ : Universe.
Variable a8_ : Universe.
Variable a7_ : Universe.
Variable a6_ : Universe.
Variable a5_ : Universe.
Variable a4_ : Universe.
Variable a3_ : Universe.
Variable a21_ : Universe.
Variable a20_ : Universe.
Variable a2_ : Universe.
Variable a19_ : Universe.
Variable a18_ : Universe.
Variable a17_ : Universe.
Variable a16_ : Universe.
Variable a15_ : Universe.
Variable a14_ : Universe.
Variable a13_ : Universe.
Variable a12_ : Universe.
Variable a11_ : Universe.
Variable a10_ : Universe.
Variable a1_ : Universe.

Variable ax1_1 : (dom_ a1_ /\ (dom_ a2_ /\ (dom_ a3_ /\ (dom_ a4_ /\ (dom_ a5_ /\ (dom_ a6_ /\ (dom_ a7_ /\ (dom_ a8_ /\ (dom_ a9_ /\ (dom_ a10_ /\ (dom_ a11_ /\ (dom_ a12_ /\ (dom_ a13_ /\ (dom_ a14_ /\ (dom_ a15_ /\ (dom_ a16_ /\ (dom_ a17_ /\ (dom_ a18_ /\ (dom_ a19_ /\ (dom_ a20_ /\ dom_ a21_)))))))))))))))))))).
Variable ax2_2 : (forall A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 A11 A12 A13 A14 A15 A16 A17 A18 A19 A20 A21 : Universe, ((dom_ A1 /\ (dom_ A2 /\ (dom_ A3 /\ (dom_ A4 /\ (dom_ A5 /\ (dom_ A6 /\ (dom_ A7 /\ (dom_ A8 /\ (dom_ A9 /\ (dom_ A10 /\ (dom_ A11 /\ (dom_ A12 /\ (dom_ A13 /\ (dom_ A14 /\ (dom_ A15 /\ (dom_ A16 /\ (dom_ A17 /\ (dom_ A18 /\ (dom_ A19 /\ (dom_ A20 /\ dom_ A21)))))))))))))))))))) -> p_ A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 A11 A12 A13 A14 A15 A16 A17 A18 A19 A20 A21)).
Variable ax3_3 : (p_ a21_ a20_ a19_ a18_ a17_ a16_ a15_ a14_ a13_ a12_ a11_ a10_ a9_ a8_ a7_ a6_ a5_ a4_ a3_ a2_ a1_ -> goal_).

Theorem lemma21_4 : goal_.
Proof.
  time tac.
Qed.

End FOFProblem.