Require Import RelationClasses.

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

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import Language.
From PromisingLib Require Import Loc.
Require Import Time.
Require Import Event.
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 Progress.
Require Import Behavior.
Require Import Cover.
Require Import PromiseConsistent.
Require Import Pred.
Require Import Trace.
Require Import JoinedView.

Require Import MemoryProps.

Require Import Single.
Require Import PFStep.
Require Import LocalDRFPF.

Set Implicit Arguments.

Section NOTRELEASED.

  Variable loc: Loc.t.
  Variable ts: Time.t.
  Hypothesis NONBOT: ts <> Time.bot.

  Definition not_released_timemap (tm: TimeMap.t) := tm loc <> ts.

  Record not_released_view (vw: View.t): Prop :=
    {
      not_released_pln: not_released_timemap (View.pln vw);
      not_released_rlx: not_released_timemap (View.rlx vw);
    }.
  Hint Constructors not_released_view.

  Inductive not_released_opt_view: option View.t -> Prop :=
  | not_released_opt_view_some
      vw
      (RELEASED: not_released_view vw)
    :
      not_released_opt_view (Some vw)
  | not_released_opt_view_none
    :
      not_released_opt_view None
  .
  Hint Constructors not_released_opt_view.

  Inductive not_released_message: Message.t -> Prop :=
  | not_released_message_concrete
      val released
      (RELEASED: not_released_opt_view released)
    :
      not_released_message (Message.concrete val released)
  | not_released_message_reserve
    :
      not_released_message Message.reserve
  .
  Hint Constructors not_released_message.

  Record not_released_tview (vw: TView.t): Prop :=
    {
      not_released_rel: forall loc0, not_released_view ((TView.rel vw) loc0);
      not_released_cur: not_released_view (TView.cur vw);
      not_released_acq: not_released_view (TView.acq vw);
    }.
  Hint Constructors not_released_tview.

  Lemma not_released_timemap_bot
    :
      not_released_timemap TimeMap.bot.
  Proof.
    ii. eapply NONBOT. eauto.
  Qed.

  Lemma not_released_timemap_join tm0 tm1
      (TM0: not_released_timemap tm0)
      (TM1: not_released_timemap tm1)
    :
      not_released_timemap (TimeMap.join tm0 tm1).
  Proof.
    ii. unfold TimeMap.join, Time.join in *. des_ifs.
  Qed.

  Lemma not_released_timemap_singleton_join loc0 ts0
        (NEQ: (loc0, ts0) <> (loc, ts))
    :
      not_released_timemap (TimeMap.singleton loc0 ts0).
  Proof.
    ii. unfold TimeMap.singleton in *.
    setoid_rewrite LocFun.add_spec in H. des_ifs.
  Qed.

  Lemma not_released_view_bot
    :
      not_released_view View.bot.
  Proof.
    econs; eapply not_released_timemap_bot.
  Qed.

  Lemma not_released_unwrap vw
        (RELEASED: not_released_opt_view vw)
    :
      not_released_view (View.unwrap vw).
  Proof.
    inv RELEASED; ss. eapply not_released_view_bot.
  Qed.

  Lemma not_released_view_join vw0 vw1
        (VW0: not_released_view vw0)
        (VW1: not_released_view vw1)
    :
      not_released_view (View.join vw0 vw1).
  Proof.
    inv VW0. inv VW1.
    econs; eapply not_released_timemap_join; eauto.
  Qed.

  Lemma not_released_view_singleton_ur loc0 ts0
        (NEQ: (loc0, ts0) <> (loc, ts))
    :
      not_released_view (View.singleton_ur loc0 ts0).
  Proof.
    econs; ss; eapply not_released_timemap_singleton_join; eauto.
  Qed.

  Lemma not_released_view_singleton_rw loc0 ts0
        (NEQ: (loc0, ts0) <> (loc, ts))
    :
      not_released_view (View.singleton_rw loc0 ts0).
  Proof.
    econs; ss.
    - eapply not_released_timemap_bot; eauto.
    - eapply not_released_timemap_singleton_join; eauto.
  Qed.

  Lemma not_released_view_singleton_ur_if cond loc0 ts0
        (NEQ: (loc0, ts0) <> (loc, ts))
    :
      not_released_view (View.singleton_ur_if cond loc0 ts0).
  Proof.
    unfold View.singleton_ur_if. des_ifs.
    - eapply not_released_view_singleton_ur; eauto.
    - eapply not_released_view_singleton_rw; eauto.
  Qed.

  Inductive not_released_memory (prom mem: Memory.t): Prop :=
  | not_released_memory_intro
      (MESSAGES: forall loc0 ts0 from msg
                        (GET: Memory.get loc0 ts0 mem = Some (from, msg))
                        (LOCTS: (loc0, ts0) <> (loc, ts)),
          (<<RELEASED: not_released_message msg>>) \/ (<<GET: Memory.get loc0 ts0 prom = Some (from, msg)>>))
      (EXIST: exists from val released, Memory.get loc ts mem = Some (from, Message.concrete val released))
      (NONE: Memory.get loc ts prom = None)
  .

  Inductive not_released_thread lang (th: Thread.t lang): Prop :=
  | not_released_thread_intro
      (TVIEW: not_released_tview (Local.tview (Thread.local th)))
      (MEM: not_released_memory (Local.promises (Thread.local th)) (Thread.memory th))
      (SC: not_released_timemap (Thread.sc th))
  .

  Lemma not_released_promise_neq prom0 mem0 loc0 from to msg prom1 mem1 kind
        (PROMISE: Memory.promise prom0 mem0 loc0 from to msg prom1 mem1 kind)
        (RELEASED: not_released_memory prom0 mem0)
    :
      (loc0, to) <> (loc, ts).
  Proof.
    ii. clarify. inv RELEASED. des. inv PROMISE.
    - eapply Memory.add_get0 in MEM. eapply Memory.add_get0 in PROMISES.
      des. clarify.
    - eapply Memory.split_get0 in MEM. eapply Memory.split_get0 in PROMISES.
      des. clarify.
    - eapply Memory.lower_get0 in MEM. eapply Memory.lower_get0 in PROMISES.
      des. clarify.
    - eapply Memory.remove_get0 in MEM. eapply Memory.remove_get0 in PROMISES.
      des. clarify.
  Qed.

  Lemma not_released_promise prom0 mem0 loc0 from to msg prom1 mem1 kind
        (PROMISE: Memory.promise prom0 mem0 loc0 from to msg prom1 mem1 kind)
        (RELEASED: not_released_memory prom0 mem0)
    :
      not_released_memory prom1 mem1.
  Proof.
    hexploit not_released_promise_neq; eauto. intros NEQ.
    inv RELEASED. inv PROMISE.
    - econs.
      + ii. erewrite Memory.add_o in GET; eauto.
        erewrite (@Memory.add_o prom1 prom0); eauto. des_ifs; auto.
      + des. eapply Memory.add_get1 in EXIST; eauto.
      + erewrite Memory.add_o; eauto. des_ifs. ss. des; clarify.
    - econs.
      + ii. erewrite Memory.split_o in GET; eauto.
        erewrite (@Memory.split_o prom1 prom0); eauto. des_ifs; auto.
      + des. eapply Memory.split_get1 in EXIST; eauto. des. eauto.
      + erewrite Memory.split_o; eauto. des_ifs.
        * ss. des; clarify.
        * ss. des; clarify.
          eapply Memory.split_get0 in PROMISES. des. clarify.
    - econs.
      + ii. erewrite Memory.lower_o in GET; eauto.
        erewrite (@Memory.lower_o prom1 prom0); eauto. des_ifs; auto.
      + des. eapply Memory.lower_get1 in EXIST; eauto. des.
        clarify. inv MSG_LE. eauto.
      + erewrite Memory.lower_o; eauto. des_ifs. ss. des; clarify.
    - econs.
      + ii. erewrite Memory.remove_o in GET; eauto.
        erewrite (@Memory.remove_o prom1 prom0); eauto. des_ifs; auto.
      + des. eapply Memory.remove_get1 in EXIST; eauto. des; eauto. clarify.
      + erewrite Memory.remove_o; eauto. des_ifs.
  Qed.

  Lemma not_released_fulfill prom0 loc0 from to msg prom1 mem
        (FULFILL: Memory.remove prom0 loc0 from to msg prom1)
        (RELEASED: not_released_memory prom0 mem)
        (RELEASEDM: not_released_message msg)
        (GET: Memory.get loc0 to mem = Some (from, msg))
    :
      not_released_memory prom1 mem.
  Proof.
    econs.
    - ii. dup GET0. eapply RELEASED in GET0.
      { erewrite Memory.remove_o; eauto.
        des; auto. des_ifs; auto. ss. des; clarify. left. auto. }
      { ii. clarify. }
    - eapply RELEASED.
    - inv RELEASED. erewrite Memory.remove_o; eauto. des_ifs.
  Qed.

  Lemma not_released_read lc0 mem0 loc0 ts0 val released ord lc1
        (READ: Local.read_step lc0 mem0 loc0 ts0 val released ord lc1)
        (TVIEW: not_released_tview (Local.tview lc0))
        (MEM: not_released_memory (Local.promises lc0) mem0)
        (CONSISTENT: Local.promise_consistent lc1)
        (NOTREAD: (loc0, ts0) <> (loc, ts))
    :
      (<<TVIEW: not_released_tview (Local.tview lc1)>>) /\
      (<<MEM: not_released_memory (Local.promises lc1) mem0>>) /\
      (<<RELEASEDM: not_released_opt_view released>>).
  Proof.
    inv READ. inv MEM. exploit MESSAGES; eauto. i. des.
    { inv RELEASED. splits; ss.
      { econs; ss.
        { eapply TVIEW; eauto. }
        { eapply not_released_view_join.
          { eapply not_released_view_join.
            { eapply TVIEW; eauto. }
            { eapply not_released_view_singleton_ur_if; eauto. }
          }
          { des_ifs.
            { eapply not_released_unwrap; eauto. }
            { eapply not_released_view_bot; eauto. }
          }
        }
        { eapply not_released_view_join.
          { eapply not_released_view_join.
            { eapply TVIEW; eauto. }
            { eapply not_released_view_singleton_ur_if; eauto. }
          }
          { des_ifs.
            { eapply not_released_unwrap; eauto. }
            { eapply not_released_view_bot; eauto. }
          }
        }
      }
      { econs; eauto. }
    }
    { exfalso. eapply CONSISTENT in GET0. ss.
      eapply Time.lt_strorder. eapply TimeFacts.lt_le_lt; eauto.
      etrans; [|try apply TimeMap.join_l].
      etrans; [|try apply TimeMap.join_r]. clear GET0.
      unfold View.singleton_ur_if. des_ifs; ss.
      { unfold TimeMap.singleton. setoid_rewrite LocFun.add_spec_eq. refl. }
      { unfold TimeMap.singleton. setoid_rewrite LocFun.add_spec_eq. refl. }
    }
  Qed.

  Lemma not_released_read_racy lc0 mem0 val released ord lc1
        (READ: Local.read_step lc0 mem0 loc ts val released ord lc1)
        (TVIEW: not_released_tview (Local.tview lc0))
        (MEM: not_released_memory (Local.promises lc0) mem0)
        (CONSISTENT: Local.promise_consistent lc1)
    :
      Time.lt (if Ordering.le Ordering.relaxed ord
               then ((TView.cur (Local.tview lc0)).(View.rlx) loc)
               else ((TView.cur (Local.tview lc0)).(View.pln) loc)) ts.
  Proof.
    inv READ. inv READABLE. des_ifs.
    { exploit RLX; eauto. intros H. inv H; eauto. inv H0. exfalso.
      eapply (not_released_rlx (not_released_cur TVIEW)); auto. }
    { inv PLN; eauto. inv H. exfalso.
      eapply (not_released_pln (not_released_cur TVIEW)); auto. }
  Qed.

  Lemma not_released_write lc0 sc0 mem0 loc0 from to val releasedr releasedm ord lc1 sc1 mem1 kind
        (WRITE: Local.write_step lc0 sc0 mem0 loc0 from to val releasedr releasedm ord lc1 sc1 mem1 kind)
        (TVIEW: not_released_tview (Local.tview lc0))
        (MEM: not_released_memory (Local.promises lc0) mem0)
        (SC: not_released_timemap sc0)
        (RELEASEDR: not_released_opt_view releasedr)
    :
      (<<TVIEW: not_released_tview (Local.tview lc1)>>) /\
      (<<MEM: not_released_memory (Local.promises lc1) mem1>>) /\
      (<<SC: not_released_timemap sc1>>).
  Proof.
    inv WRITE. inv WRITE0.
    hexploit not_released_promise_neq; eauto. intros NEQ.
    hexploit not_released_promise; eauto. intros MEM0.
    assert (WRITETIVEW: not_released_tview (TView.write_tview (Local.tview lc0) sc0 loc0 to ord)).
    { econs; ss.
      { i. setoid_rewrite LocFun.add_spec. des_ifs.
        { eapply not_released_view_join; eauto.
          { eapply TVIEW. }
          { eapply not_released_view_singleton_ur; eauto. }
        }
        { eapply not_released_view_join; eauto.
          { eapply TVIEW. }
          { eapply not_released_view_singleton_ur; eauto. }
        }
        { eapply TVIEW. }
      }
      { eapply not_released_view_join; eauto.
        { eapply TVIEW. }
        { eapply not_released_view_singleton_ur; eauto. }
      }
      { eapply not_released_view_join; eauto.
        { eapply TVIEW. }
        { eapply not_released_view_singleton_ur; eauto. }
      }
    }
    splits; ss. eapply not_released_fulfill; eauto.
    { econs. unfold TView.write_released. des_ifs. econs.
      eapply not_released_view_join; eauto.
      { eapply not_released_unwrap; eauto. }
      { eapply WRITETIVEW. }
    }
    { eapply Memory.promise_get2 in PROMISE.
      { des; eauto. }
      { destruct kind; ss. inv PROMISE. ss. }
    }
  Qed.

  Lemma not_released_read_fence_tview tvw ord
        (TVIEW: not_released_tview tvw)
    :
      not_released_tview (TView.read_fence_tview tvw ord).
  Proof.
    econs; ss.
    { eapply TVIEW. }
    { des_ifs; eapply TVIEW. }
    { eapply TVIEW. }
  Qed.

  Lemma not_released_write_fence_sc tvw sc ord
        (TVIEW: not_released_tview tvw)
        (SC: not_released_timemap sc)
    :
      not_released_timemap (TView.write_fence_sc tvw sc ord).
  Proof.
    unfold TView.write_fence_sc. des_ifs.
    eapply not_released_timemap_join; eauto. eapply TVIEW.
  Qed.

  Lemma not_released_write_fence_tview tvw sc ord
        (TVIEW: not_released_tview tvw)
        (SC: not_released_timemap sc)
    :
      not_released_tview (TView.write_fence_tview tvw sc ord).
  Proof.
    econs; ss.
    { i. des_ifs.
      { econs; eapply not_released_write_fence_sc; eauto. }
      { eapply TVIEW. }
      { eapply TVIEW. }
    }
    { des_ifs.
      { econs; eapply not_released_write_fence_sc; eauto. }
      { eapply TVIEW. }
    }
    { eapply not_released_view_join.
      { eapply TVIEW. }
      des_ifs.
      { econs; eapply not_released_write_fence_sc; eauto. }
      { eapply not_released_view_bot. }
    }
  Qed.

  Lemma not_released_fence lc0 sc0 ordr ordw lc1 sc1 mem
        (FENCE: Local.fence_step lc0 sc0 ordr ordw lc1 sc1)
        (TVIEW: not_released_tview (Local.tview lc0))
        (MEM: not_released_memory (Local.promises lc0) mem)
        (SC: not_released_timemap sc0)
    :
      (<<TVIEW: not_released_tview (Local.tview lc1)>>) /\
      (<<MEM: not_released_memory (Local.promises lc1) mem>>) /\
      (<<SC: not_released_timemap sc1>>).
  Proof.
    inv FENCE. splits; ss.
    { eapply not_released_write_fence_tview; eauto.
      eapply not_released_read_fence_tview; eauto.
    }
    { eapply not_released_write_fence_sc; eauto.
      eapply not_released_read_fence_tview; eauto.
    }
  Qed.

  Lemma not_released_thread_step lang (th0 th1: Thread.t lang) pf e
        (STEP: Thread.step pf e th0 th1)
        (CONSISTENT: Local.promise_consistent (Thread.local th1))
        (THREAD: not_released_thread th0)
    :
      (<<THREAD: not_released_thread th1>> /\ <<RACY: ~ PFRace.reading_event loc ts e>>) \/
      (<<RACY: PFRace.racy_read loc ts (Thread.local th0) e>>).
  Proof.
    inv THREAD. inv STEP.
    { inv STEP0. inv LOCAL. ss. exploit not_released_promise; eauto.
      i. left. splits; ss; eauto. ii. inv H. }
    { inv STEP0. inv LOCAL; ss.
      { left. splits; [|intros H; inv H]. econs; eauto. }
      { destruct (loc_ts_eq_dec (loc0, ts0) (loc, ts)).
        { ss. des; clarify. right.
          exploit not_released_read_racy; eauto. i. econs; eauto.
        }
        { exploit not_released_read; eauto.
          { ii. ss. des; clarify. }
          guardH o. i. des. left. splits.
          { econs; eauto. }
          { ii. inv H. ss. unguard. des; clarify. }
        }
      }
      { exploit not_released_write; eauto. i. des.
        left. splits; [|intros H; inv H]. econs; eauto. }
      { eapply write_step_promise_consistent in CONSISTENT; eauto.
        destruct (loc_ts_eq_dec (loc0, tsr) (loc, ts)).
        { ss. des; clarify. right.
          exploit not_released_read_racy; eauto. i. econs; eauto.
        }
        { exploit not_released_read; eauto.
          { ii. ss. des; clarify. }
          guardH o. i. des. left.
          exploit not_released_write; eauto. i. des. splits.
          { econs; eauto. }
          { ii. inv H. ss. unguard. des; clarify. }
        }
      }
      { exploit not_released_fence; eauto.
        i. des. left. splits; [|intros H; inv H]. econs; eauto. }
      { exploit not_released_fence; eauto.
        i. des. left. splits; [|intros H; inv H]. econs; eauto. }
      { inv LOCAL0. left. splits; [|intros H; inv H]. econs; eauto. }
    }
  Qed.

  Lemma not_released_thread_opt_step lang (th0 th1: Thread.t lang) e
        (STEP: Thread.opt_step e th0 th1)
        (CONSISTENT: Local.promise_consistent (Thread.local th1))
        (THREAD: not_released_thread th0)
    :
      (<<THREAD: not_released_thread th1>> /\ <<RACY: ~ PFRace.reading_event loc ts e>>) \/
      (<<RACY: PFRace.racy_read loc ts (Thread.local th0) e>>).
  Proof.
    inv STEP; eauto.
    { left. splits; auto. ii. inv H. }
    { eapply not_released_thread_step; eauto. }
  Qed.

  Lemma not_released_rtc_reserve_step lang (th0 th1: Thread.t lang)
        (STEPS: rtc (@Thread.reserve_step _) th0 th1)
        (CONSISTENT: Local.promise_consistent (Thread.local th1))
        (THREAD: not_released_thread th0)
    :
      not_released_thread th1.
  Proof.
    ginduction STEPS; eauto. i. eapply IHSTEPS; eauto.
    inv H. eapply not_released_thread_step in STEP; eauto.
    { des; auto. inv RACY. }
    { eapply rtc_reserve_step_promise_consistent; eauto. }
  Qed.

  Lemma not_released_rtc_cancel_step lang (th0 th1: Thread.t lang)
        (STEPS: rtc (@Thread.cancel_step _) th0 th1)
        (CONSISTENT: Local.promise_consistent (Thread.local th1))
        (THREAD: not_released_thread th0)
    :
      not_released_thread th1.
  Proof.
    ginduction STEPS; eauto. i. eapply IHSTEPS; eauto.
    inv H. eapply not_released_thread_step in STEP; eauto.
    { des; auto. inv RACY. }
    { eapply rtc_cancel_step_promise_consistent; eauto. }
  Qed.

  Definition not_released_configuration tid (c: Configuration.t): Prop :=
    forall lang st lc
           (TID: IdentMap.find tid (Configuration.threads c) = Some (existT _ lang st, lc)),
      not_released_thread (Thread.mk _ st lc (Configuration.sc c) (Configuration.memory c)).

  Lemma not_released_configuration_step L tid e c0 c1
        (STEP: PFConfiguration.step L e tid c0 c1)
        (CONFIGURATION: not_released_configuration tid c0)
        (WF: Configuration.wf c0)
    :
      (<<RELEASED: not_released_configuration tid c1>> /\ <<RACY: ~ PFRace.reading_event loc ts e>>) \/
      (<<RACY: PFRace.racy_read_step L loc ts e tid c0 c1>>).
  Proof.
    inv STEP.
    exploit Thread.rtc_cancel_step_future; eauto; try eapply WF; eauto. i. des. ss.
    exploit Thread.opt_step_future; eauto. i. des. ss.
    exploit Thread.rtc_reserve_step_future; eauto. i. des. ss.
    assert (CONSISTENT4: Local.promise_consistent lc4).
    { destruct (classic (e = ThreadEvent.failure)).
      { subst. eapply rtc_reserve_step_promise_consistent2 in RESERVES; eauto.
        inv STEP0. inv STEP; inv STEP0; inv LOCAL. inv LOCAL0. ss. }
      { specialize (CONSISTENT H).
        eapply PF.pf_consistent_consistent in CONSISTENT.
        eapply consistent_promise_consistent in CONSISTENT; eauto. }
    }
    assert (CONSISTENT3: Local.promise_consistent (Thread.local e3)).
    { eapply rtc_reserve_step_promise_consistent; eauto. }
    assert (CONSISTENT2: Local.promise_consistent (Thread.local e2)).
    { inv STEP0; eauto. eapply step_promise_consistent; eauto. }
    assert (CONSISTENT1: Local.promise_consistent lc1).
    { eapply rtc_cancel_step_promise_consistent in CANCELS; eauto. }
    exploit not_released_rtc_cancel_step; eauto. intros RELEASED2.
    exploit not_released_thread_opt_step; eauto. i. des.
    { exploit not_released_rtc_reserve_step; eauto. intros RELEASED4.
      inv RELEASED4. ss. left. splits; auto. ii. ss.
      erewrite IdentMap.gss in TID0. dep_clarify. }
    { right. econs; eauto. }
  Qed.

  Lemma not_released_configuration_steps L tid c0 c1
        (STEPS: rtc (PFConfiguration.machine_step L MachineEvent.silent tid) c0 c1)
        (CONFIGURATION: not_released_configuration tid c0)
        (WF: Configuration.wf c0)
    :
      (<<RELEASED: not_released_configuration tid c1>>) \/
      (exists c1' c2' e,
          (<<STEPS: rtc (PFConfiguration.machine_step L MachineEvent.silent tid) c0 c1'>>) /\
          (<<RACY: PFRace.racy_read_step L loc ts e tid c1' c2'>>)).
  Proof.
    ginduction STEPS; eauto. i. inv H.
    exploit not_released_configuration_step; eauto. i. des.
    { erewrite H1. exploit IHSTEPS; eauto.
      { eapply PFConfiguration.step_event_configuration_step in STEP; eauto.
        des. eapply SConfiguration.step_future; eauto. }
      i. des; auto. right. exists c1', c2'. esplits; eauto.
      econs 2; eauto. erewrite <- H1. econs; eauto.
    }
    { right. esplits; eauto. }
  Qed.

  Lemma promise_not_released_timemap prom0 mem0 from msg prom1 mem1
        (PROMISE: Memory.promise prom0 mem0 loc from ts msg prom1 mem1 Memory.op_kind_add)
        tm
        (TM: Memory.closed_timemap tm mem0)
    :
      not_released_timemap tm.
  Proof.
    inv PROMISE. ii.
    specialize (TM loc). des. eapply Memory.add_get0 in MEM.
    des. rewrite H in *. clarify.
  Qed.

  Lemma promise_not_released_view prom0 mem0 from msg prom1 mem1
        (PROMISE: Memory.promise prom0 mem0 loc from ts msg prom1 mem1 Memory.op_kind_add)
        vw
        (VW: Memory.closed_view vw mem0)
    :
      not_released_view vw.
  Proof.
    inv VW. econs; eapply promise_not_released_timemap; eauto.
  Qed.

  Lemma promise_not_released_tview prom0 mem0 from msg prom1 mem1
        (PROMISE: Memory.promise prom0 mem0 loc from ts msg prom1 mem1 Memory.op_kind_add)
        vw
        (VW: TView.closed vw mem0)
    :
      not_released_tview vw.
  Proof.
    inv VW. econs; i; eapply promise_not_released_view; eauto.
  Qed.

  Lemma promise_not_released_opt_view prom0 mem0 from msg prom1 mem1
        (PROMISE: Memory.promise prom0 mem0 loc from ts msg prom1 mem1 Memory.op_kind_add)
        vw
        (VW: Memory.closed_opt_view vw mem0)
    :
      not_released_opt_view vw.
  Proof.
    inv VW; econs. eapply promise_not_released_view; eauto.
  Qed.

  Lemma promise_not_released_message prom0 mem0 from msg prom1 mem1
        (PROMISE: Memory.promise prom0 mem0 loc from ts msg prom1 mem1 Memory.op_kind_add)
        msg0
        (MSG: Memory.closed_message msg0 mem0)
    :
      not_released_message msg0.
  Proof.
    inv MSG; econs. eapply promise_not_released_opt_view; eauto.
  Qed.

  Lemma promise_not_released_memory prom0 mem0 from val released prom1 mem1
        (PROMISE: Memory.promise prom0 mem0 loc from ts (Message.concrete val released) prom1 mem1 Memory.op_kind_add)
        (MEM: Memory.closed mem0)
        prom
        (MLE: Memory.le prom mem0)
    :
      not_released_memory prom mem1.
  Proof.
    inversion PROMISE. econs.
    { i. erewrite Memory.add_o in GET; eauto. des_ifs.
      { ss. des; clarify. }
      { left. eapply promise_not_released_message; eauto. eapply MEM; eauto. }
    }
    { eapply Memory.add_get0 in MEM0. des. eauto. }
    { destruct (Memory.get loc ts prom) as [[from0 msg]|] eqn:GET; auto.
      eapply MLE in GET. eapply Memory.add_get0 in MEM0. des. clarify. }
  Qed.

End NOTRELEASED.

Lemma promise_not_released_add L loc ts prom0 mem0 from val released prom1 mem1 kind
      (PROMISE: Memory.promise prom0 mem0 loc from ts (Message.concrete val released) prom1 mem1 kind)
      (PF: PF.pf_promises L prom0)
      (LOC: L loc)
  :
    (<<KIND: kind = Memory.op_kind_add>>) /\ (<<NONBOT: ts <> Time.bot>>).
Proof.
  inv PROMISE.
  { splits; auto.
    ii. subst. eapply add_succeed_wf in MEM. des.
    eapply Time.lt_strorder. eapply TimeFacts.le_lt_lt; eauto. eapply Time.bot_spec.
  }
  { eapply Memory.split_get0 in PROMISES. des. subst.
    eapply PF in GET0; eauto. ss. }
  { eapply Memory.lower_get0 in PROMISES. des. subst.
    eapply PF in GET; eauto. ss. }
  { ss. }
Qed.

Lemma thread_step_write_not_released L loc ts lang (th0 th1: Thread.t lang) pf e
      lc_other
      (STEP: Thread.step pf e th0 th1)
      (WRITE: PFRace.writing_event loc ts e)
      (PF: PF.pf_promises L (Local.promises (Thread.local th0)))
      (LOCAL: Local.wf (Thread.local th0) (Thread.memory th0))
      (SC: Memory.closed_timemap (Thread.sc th0) (Thread.memory th0))
      (MEM: Memory.closed (Thread.memory th0))
      (LOC: L loc)
      (LOCALOTHER: Local.wf lc_other (Thread.memory th0))
  :
    (<<NONBOT: ts <> Time.bot>>) /\
    (<<TVIEW: not_released_tview loc ts (Local.tview lc_other)>>) /\
    (<<MEM: not_released_memory loc ts (Local.promises lc_other) (Thread.memory th1)>>) /\
    (<<SC: not_released_timemap loc ts (Thread.sc th1)>>).
Proof.
  inv STEP; inv STEP0; ss.
  { inv WRITE. }
  inv WRITE; inv LOCAL0.
  { inv LOCAL1. inv WRITE.
    exploit promise_not_released_add; eauto. i. des; subst. splits; auto.
    { eapply promise_not_released_tview; eauto. eapply LOCALOTHER. }
    { eapply promise_not_released_memory; eauto. eapply LOCALOTHER. }
    { eapply promise_not_released_timemap; eauto. }
  }
  { inv LOCAL1. inv LOCAL2. inv WRITE. ss.
    exploit promise_not_released_add; eauto. i. des; subst. splits; auto.
    { eapply promise_not_released_tview; eauto. eapply LOCALOTHER. }
    { eapply promise_not_released_memory; eauto. eapply LOCALOTHER. }
    { eapply promise_not_released_timemap; eauto. }
  }
Qed.

Lemma rtc_reserve_step_write_not_released loc ts lang (th0 th1: Thread.t lang)
      lc_other
      (STEPS: rtc (@Thread.reserve_step _) th0 th1)
      (TVIEW: not_released_tview loc ts (Local.tview lc_other))
      (MEM: not_released_memory loc ts (Local.promises lc_other) (Thread.memory th0))
      (SC: not_released_timemap loc ts (Thread.sc th0))
  :
    (<<TVIEW: not_released_tview loc ts (Local.tview lc_other)>>) /\
    (<<MEM: not_released_memory loc ts (Local.promises lc_other) (Thread.memory th1)>>) /\
    (<<SC: not_released_timemap loc ts (Thread.sc th1)>>).
Proof.
  ginduction STEPS; eauto.
  i. inv H. inv STEP; inv STEP0; inv LOCAL. ss. inv PROMISE.
  eapply IHSTEPS; eauto. inv MEM. des. econs; eauto.
  { i. erewrite Memory.add_o in GET; eauto. des_ifs.
    { ss. des; clarify. left. econs. }
    { eapply MESSAGES; eauto. }
  }
  { eapply Memory.add_get1 in EXIST; eauto. }
Qed.

Lemma configuration_write_not_released L c0 c1 e loc ts tid0 tid1
      (WRITE: PFRace.writing_event loc ts e)
      (STEP: PFConfiguration.step L e tid0 c0 c1)
      (WF: Configuration.wf c0)
      (PF: PF.pf_configuration L c0)
      (TID: tid0 <> tid1)
      (LOC: L loc)
  :
    (<<NONBOT: ts <> Time.bot>>) /\ (<<RELEASED: not_released_configuration loc ts tid1 c1>>).
Proof.
  inv STEP. hexploit (PF tid0); eauto. intros PROMISES.
  exploit Thread.rtc_cancel_step_future; eauto; try eapply WF; eauto.
  i. des. ss.
  inv STEP0.
  { inv WRITE. }
  hexploit PF.pf_promises_cancel_steps; eauto. intros PROMISES2. splits.
  { inv WRITE.
    { inv STEP; inv STEP0; inv LOCAL. ss.
      inv LOCAL0. inv WRITE.
      eapply promise_not_released_add in PROMISE; eauto. des; auto. }
    { inv STEP; inv STEP0; inv LOCAL. ss.
      inv LOCAL1. inv LOCAL2. inv WRITE.
      eapply promise_not_released_add in PROMISE; eauto. des; auto. }
  }
  { ii. ss. erewrite IdentMap.gso in TID1; eauto.
    hexploit Thread.rtc_all_step_disjoint.
    { eapply rtc_implies; try apply CANCELS.
      clear. i. inv H. econs. econs; eauto. }
    { eapply WF; eauto. }
    { eapply WF; eauto. }
    { eapply WF; eauto. }
    { eapply WF; eauto. }
    { eapply WF; eauto. }
    i. des.
    hexploit thread_step_write_not_released; eauto. i. des.
    hexploit rtc_reserve_step_write_not_released; eauto. i. des. ss.
  }
Qed.

Lemma pf_racefree_view_pf_race_free_imm L c
      (WF: Configuration.wf c)
      (PF: PF.pf_configuration L c)
      (RACEFREE: PFRace.racefree_view L c)
  :
    PFRace.racefree L c.
Proof.
  ii. exploit PFConfiguration.rtc_all_step_future; eauto. i. des.
  exploit configuration_write_not_released; eauto. i. des.
  exploit PFConfiguration.step_future; try apply CSTEP0; eauto. i. des.
  exploit not_released_configuration_steps; eauto. i. des.
  { exploit not_released_configuration_step; try apply CSTEP1; eauto.
    { eapply PFConfiguration.rtc_all_step_future; try apply WF0; eauto.
      eapply rtc_implies; try apply STEPS.
      i. inv H. econs; eauto. }
    i. des; ss.
    eapply RACEFREE.
    { eauto. }
    { eapply CSTEPS. }
    { econs; eauto. }
    { eapply rtc_implies; try apply STEPS.
      i. inv H. econs; eauto. }
    { eauto. }
  }
  { eapply RACEFREE.
    { eauto. }
    { eapply CSTEPS. }
    { econs; eauto. }
    { eapply rtc_implies; try apply STEPS0.
      i. inv H. econs; eauto. }
    { eauto. }
  }
Qed.

Lemma local_drf_pf_view_after L c
        (WF: Configuration.wf c)
        (PF: PF.pf_configuration L c)
        (RACEFRFEE: PFRace.racefree_view L c)
  :
    behaviors SConfiguration.machine_step c <1=
    behaviors (PFConfiguration.machine_step L) c.
Proof.
  ii. eapply local_drf_pf_after; eauto.
  eapply pf_racefree_view_pf_race_free_imm; eauto.
Qed.

(* Happens-before based LDRF-PF theorem *)
Theorem local_drf_pf_view L
        s
        (RACEFRFEE: PFRace.racefree_view_syn L s):
  behaviors SConfiguration.machine_step (Configuration.init s) <1=
  behaviors (PFConfiguration.machine_step L) (Configuration.init s).
Proof.
  eapply local_drf_pf_view_after; eauto.
  - eapply Configuration.init_wf.
  - eapply PF.configuration_init_pf.
Qed.


From iris.program_logic Require Import weakestpre adequacy.
From iris.proofmode Require Import tactics.
From st.backtranslations.st_sem.correctness Require Import
     sem_le_st.logrel.definition sem_le_st.logrel.adequacy sem_le_st.logrel.fundamental
     st_le_sem.logrel.definition st_le_sem.logrel.adequacy st_le_sem.logrel.fundamental.
From st.STLCmuVS Require Import typing contexts scopedness logrel.definitions logrel.adequacy logrel.fundamental.
From st.STLCmuST Require Import contexts types lang.
From st.backtranslations.st_sem Require Import expressions contexts scoped retraction.
From st.backtranslations.st_sem.well_defined.logrel Require Import definition fundamental matches_sem.
From st.embedding Require Import types expressions typed.
From st.STLCmuVS Require Import lang.
From st.STLCmu Require Import types.

From st Require Import resources.

Section back_ctx_st_sem.

  (* Given any syntactically-typed context in STLCmuST, ⊢ₛₜ C : ([[Γ]];[[τ]]) ⇒ ([];1), *)
  Context (C : ctx)
          (Γ : list type) (pΓ : Forall Closed Γ) (τ : type) (pτ : Closed τ)
          (pC : typed_ctx C (embed <$> Γ) (embed τ) [] (embed TUnit)).

  (* we have a semantically typed context, C_b, *)
  Definition back_ctx_st_sem : STLCmuVS.contexts.ctx :=
    back_ctx C.

  (* It is indeed semantically typed of (Γ;τ) ⇒ ([];1),
     that is, it is auto-related in our logical relation for the semantic language *)
  Lemma back_ctx_st_sem_sem_typed :
    ∀ {Σ} {semΣ_inst : semΣ Σ},
      logrel.definitions.ctx_rel_typed MaybeStuck
                                         back_ctx_st_sem
                                         back_ctx_st_sem
                                           Γ τ [] TUnit.
  Proof.
    intros Σ semΣ_inst.
    assert (ctx_rel_typed
              back_ctx_st_sem
              back_ctx_st_sem
                (embed <$> Γ) (embed τ) [] STLCmuST.types.TUnit).
    { apply ctx_fundamental. apply pC. }
    by apply matches_sem_ctx.
  Qed.

  (* Furthermore, the backtranslated contexts successfully emulates the original (when interacting with syntactically typed terms in STLCmuVS). *)
  (* That is, for all syntactically typed e, Γ ⊢ₙₒ e : τ, C_b[e]⇓ ⇔ C[[[e]]]⇓ *)

  Lemma back_ctx_st_sem_correct_emulation :
    ∀ (e : expr) (de : Γ ⊢ₙₒ e : τ),
      STLCmuVS_halts (STLCmuVS.contexts.fill_ctx back_ctx_st_sem e) <-> STLCmuST_halts (fill_ctx C (embd_expr e)).
  Proof.
    intros e de. split.
    - (* C_b[e] ⇓ ⇒ C[e] ⇓ *)
      intro LamHalts.
      (* using logical relatedness *)
      apply (correctness.sem_le_st.logrel.adequacy.exprel_adequate
               (STLCmuVS.contexts.fill_ctx back_ctx_st_sem e)); auto.
      (* proving relatedness *)
      intros Σ sem_le_stΣ_inst.
      apply correctness.sem_le_st.logrel.definition.open_exprel_typed_nil'.
      (* using relatedness of context with backtrns *)
      apply (correctness.sem_le_st.logrel.fundamental.ctx_fundamental C (embed <$> Γ) (embed τ)); auto.
      (* using fun thm *)
      rewrite <- (retraction _ _ _ de) at 1.
      apply (correctness.sem_le_st.logrel.fundamental.fundamental); by apply embd_typed.
    - (* C[e] ⇓ ⇒ C_b[e] ⇓ *)
      intro LamSTHalts.
      (* using logical relatedness *)
      apply (correctness.st_le_sem.logrel.adequacy.exprel_adequate
               (fill_ctx C [[e]])); auto.
      (* proving relatedness *)
      intros Σ st_le_semΣ_inst.
      apply correctness.st_le_sem.logrel.definition.open_exprel_typed_nil'.
      (* using relatedness of context with backtrns *)
      apply (correctness.st_le_sem.logrel.fundamental.ctx_fundamental C (embed <$> Γ) (embed τ)); auto.
      (* using fun thm *)
      rewrite <- (retraction _ _ _ de) at 2.
      apply (correctness.st_le_sem.logrel.fundamental.fundamental); by apply embd_typed.
  Qed.

End back_ctx_st_sem.


Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.lib.EnsemblesProperties.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.Complete.Lindenbaum.
Require Import Logic.GeneralLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.Complete.ContextProperty_Kripke.
Require Import Logic.MinimumLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.RewriteClass.
Require Import Logic.SeparationLogic.ProofTheory.DerivedRules.
Require Import Logic.SeparationLogic.Complete.ContextProperty_Flat.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.

Section Lindenbaum_Flat.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        {GammaP: Provable L}
        {GammaD: Derivable L}
        {SC: NormalSequentCalculus L GammaP GammaD}
        {bSC: BasicSequentCalculus L GammaD}
        {fwSC: FiniteWitnessedSequentCalculus L GammaD}
        {minSC: MinimumSequentCalculus L GammaD}
        {ipSC: IntuitionisticPropositionalSequentCalculus L GammaD}
        {AX: NormalAxiomatization L GammaP GammaD}
        {minAX: MinimumAxiomatization L GammaP}
        {ipAX: IntuitionisticPropositionalLogic L GammaP}
        {sepconAX: SepconAxiomatization L GammaP}
        {wandAX: WandAxiomatization L GammaP}
        {sepcon_orp_AX: SepconOrAxiomatization L GammaP}
        {sepcon_falsep_AX: SepconFalseAxiomatization L GammaP}.

Lemma Lindenbaum_preserves_context_sepcon_included_l: forall Phi2 Psi,
  Lindenbaum_preserves (context_sepcon_included_l Phi2 Psi).
Proof.
  intros.
  apply Lindenbaum_preserves_by_finiteness.
  + apply context_sepcon_included_l_finite_captured.
  + apply context_sepcon_included_l_subset_preserved.
Qed.

Lemma Lindenbaum_context_sepcon_included_l_ensures_derivable_closed: forall Phi Psi,
  Lindenbaum_ensures (context_sepcon_included_l Phi Psi) derivable_closed.
Proof.
  intros.
  apply Lindenbaum_for_derivable_closed.
  + apply Lindenbaum_preserves_context_sepcon_included_l.
  + apply context_sepcon_included_l_derivable_subset_preserved.
Qed.

Lemma Lindenbaum_context_sepcon_included_l_ensures_orp_witnessed: forall Phi Psi
      (DC: derivable_closed Psi)
      (OW: orp_witnessed Psi),
  Lindenbaum_ensures (context_sepcon_included_l Phi Psi) orp_witnessed.
Proof.
  intros.
  apply Lindenbaum_for_orp_witnessed.
  + apply Lindenbaum_preserves_context_sepcon_included_l.
  + apply context_sepcon_included_l_subset_preserved.
  + apply context_sepcon_included_l_context_orp_captured; auto.
  + apply Lindenbaum_context_sepcon_included_l_ensures_derivable_closed.
Qed.

Lemma Lindenbaum_context_sepcon_included_l_ensures_consistent: forall Phi Psi
  (CONSI: consistent Psi),
  Lindenbaum_ensures (context_sepcon_included_l Phi Psi) consistent.
Proof.
  intros.
  apply Lindenbaum_for_consistent.
  + apply Lindenbaum_preserves_context_sepcon_included_l.
  + intros Phi' ?.
    eapply context_sepcon_consistent_rev_left; eauto.
Qed.

End Lindenbaum_Flat.


(* TODO Will I need to recurse with delta.
   What happens if I get back a B in some cases that I want an A?
   Can I just build the context once with a B for all free type variables?
  *)

(*
Fixpoint KTau (d : Delta) (tau : Tau) : option (K d tau A) :=
  match tau with
    | cint              => Some (K_B_A d cint (K_int d))
    | cross t0 t1       =>
      match (KTau d t0), (KTau d t1) with
        | Some p0, Some p1 => Some (K_cross d t0 t1 p0 p1)
        | _, _ => None
      end
    | arrow t0 t1       =>
      match (KTau d t0), (KTau d t1) with
        | Some p0, Some p1 => Some (K_arrow d t0 t1 p0 p1)
        | _, _ => None
      end
    | ptype t0          =>
      match (KTau d t0) with
        | Some p0 => Some (K_B_A d (ptype t0) (K_ptype d t0 p0))
        | _       => None
      end
    (* Some (K_B d alpha (eq (getD d alpha) (Some B))) *)
    | tv_t alpha          => _

    (* Shit I'm not going to be able to prove getD d alpha = None. *)
    | utype alpha k tau   =>
      match (KTau (d ++ [(alpha,k)]) tau) with
        (* | Some p0 => Some (K_utype d alpha k tau p0) *)
       | _ => None
      end
    | etype phi alpha k tau  =>
      match (KTau (d ++ [(alpha,k)]) tau) with
        (* | Some p0 => Some (K_etype d alpha k tau phi p0)  *)
       | _ => None
      end
  end.

Fixpoint AKTau (tau : Tau) (d : Delta) : option (AK d tau _) :=
  match tau with
      | cint              => Some (AK_AK_K d cint A (K_B_A d cint (K_int d)))
      | cross t0 t1       =>
        match (KTau d (cross t0 t1)) with
          | Some p0 => Some (AK_AK_K d (cross t0 t1) A p0)
          | _ => None
        end
      | arrow t0 t1       =>
        match (KTau d (arrow t0 t1)) with
            | Some p0 => Some (AK_AK_K d (arrow t0 t1) A p0)
            | _ => None
        end
      | ptype t0          =>
        match (KTau d (ptype t0)) with
          | Some p0 => Some (AK_AK_K d (ptype t0) A p0)
          | _ => None
        end
      | tv_t alpha => None
      (* Some (AK_AK_K (d ++ [(alpha,B)]) (tv_t alpha) B (K_B (d ++ [(alpha,B)]) alpha)) *)
      | _ => None
  end.

Fixpoint BoxEm (taus : list TVar) : Delta :=
  match taus with
    | [] => nil
    | alpha :: taus' => (alpha,B) :: BoxEm taus'
  end.

Fixpoint AKTau' (tau : Tau) : option (AK _ tau _) :=
  AKTau tau (BoxEm (FreeVariablesTau tau)).
*)

(* This is too hard to prove due to the existentials.
   I need a function to produce the right AK'ing. *)
Lemma All_Types_Have_A_Kinding:
    forall (tau : Tau),
      exists (d : Delta) (k : Kappa),
        AK d tau k.
Proof.
  (* Induction on the type is not giving me a strong enough hypothesis
     when I have a concrete predicate. *)
  intros tau.
  induction tau.
  Focus 2.
  Case "cint".
   exists nil.
   exists A.
   constructor.
   constructor.
   constructor.
  Focus 2.
  Case "cross".
    exists nil.
    exists A.
    constructor.

    elim IHtau1.
    intros [].
    intros IHtau1'.
    elim IHtau1'.
    intros A.
    intros IHtau1''.

    elim IHtau2.
    intros [].
    intros IHtau2'.
    elim IHtau2'.
    intros A'.
    intros IHtau2''.

    inversion IHtau1''.
    inversion IHtau2''.
    crush.
    apply K_cross.
(*

   inversion IHtau1 with (d:=[]).
   inversion H5.
   crush.
   apply K_cross.
   assumption.
   assumption.
  SCase "(cross _ (tv_t _))".
   crush.
  SCase "(cross (tv_t _) _)".
   crush.
*)

(*
  SCase "arrow".
   crush.
   right.
   constructor.
   constructor.

   left.
   constructor.
   inversion H4.
   inversion H5.
   crush.
   apply K_arrow.
   assumption.
   assumption.
  SCase "arrow _ tv_t _".
  crush.
  SCase "arrow  tv_t _ _".
  crush.
  Case "ptype".
  crush.
  constructor.
  inversion H.
  crush.
  apply K_ptype.
*)
Admitted.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^510 - 290*2^496 - 1
Base: 32
***)

Definition curve : CurveParameters :=
  {|
    sz := 16%nat;
    base := 32;
    bitwidth := 32;
    s := 2^510;
    c := [(1, 1); (290, 2^496)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import spark.eval.
Require Import sparkfrontend.LibHypsNaming.
Require Import Memory Errors FunInd.
Require Import Cminor.
Require  compcert.cfrontend.Ctypes.
Require Import sparkfrontend.spark2Cminor.
Require Import sparkfrontend.compcert_utils.
Import Symbol_Table_Module.

Open Scope Z_scope.

(* *** Hack to workaround a current limitation of Functional Scheme wrt to Function. *)
(*
This should work, but Funcitonal SCheme does not generate the
inversion stuff currently. So we defined by hand the expanded versions
binopexp and unopexp with Function.

Definition binopexp :=
  Eval unfold
       Math.binary_operation
  , Math.and
  , Math.or
  , Math.eq
  , Math.ne
  , Math.lt
  , Math.le
  , Math.gt
  , Math.ge
  , Math.add
  , Math.sub
  , Math.mul
  , Math.div
  in Math.binary_operation.

Definition unopexp :=
  Eval unfold
       Math.unary_operation, Math.unary_plus, Math.unary_minus, Math.unary_not in Math.unary_operation.

Functional Scheme binopnind := Induction for binopexp Sort Prop.
Functional Scheme unopnind := Induction for unopexp Sort Prop.
*)

(* *** And of the hack *)

Function unopexp (op : unary_operator) (v : value) :=
  match op with
    | Unary_Minus =>
      match v with
        | Undefined => None
        | Int v' => Some (Int (- v'))
        | Bool _ => None
        | ArrayV _ => None
        | RecordV _ => None
      end
    | Not =>
      match v with
        | Undefined => None
        | Int _ => None
        | Bool v' => Some (Bool (negb v'))
        | ArrayV _ => None
        | RecordV _ => None
      end
  end.

Function binopexp (op : binary_operator) (v1 v2 : value) :=
match op with
| And =>
    match v1 with
    | Undefined => None
    | Int _ => None
    | Bool v1' =>
        match v2 with
        | Undefined => None
        | Int _ => None
        | Bool v2' => Some (Bool (v1' && v2'))
        | ArrayV _ => None
        | RecordV _ => None
        end
    | ArrayV _ => None
    | RecordV _ => None
    end
| Or =>
    match v1 with
    | Undefined => None
    | Int _ => None
    | Bool v1' =>
        match v2 with
        | Undefined => None
        | Int _ => None
        | Bool v2' => Some (Bool (v1' || v2'))
        | ArrayV _ => None
        | RecordV _ => None
        end
    | ArrayV _ => None
    | RecordV _ => None
    end
| Equal =>
    match v1 with
    | Undefined => None
    | Int v1' =>
        match v2 with
        | Undefined => None
        | Int v2' => Some (Bool (Zeq_bool v1' v2'))
        | Bool _ => None
        | ArrayV _ => None
        | RecordV _ => None
        end
    | Bool _ => None
    | ArrayV _ => None
    | RecordV _ => None
    end
| Not_Equal =>
    match v1 with
    | Undefined => None
    | Int v1' =>
        match v2 with
        | Undefined => None
        | Int v2' => Some (Bool (Zneq_bool v1' v2'))
        | Bool _ => None
        | ArrayV _ => None
        | RecordV _ => None
        end
    | Bool _ => None
    | ArrayV _ => None
    | RecordV _ => None
    end
| Less_Than =>
    match v1 with
    | Undefined => None
    | Int v1' =>
        match v2 with
        | Undefined => None
        | Int v2' => Some (Bool (v1' <? v2'))
        | Bool _ => None
        | ArrayV _ => None
        | RecordV _ => None
        end
    | Bool _ => None
    | ArrayV _ => None
    | RecordV _ => None
    end
| Less_Than_Or_Equal =>
    match v1 with
    | Undefined => None
    | Int v1' =>
        match v2 with
        | Undefined => None
        | Int v2' => Some (Bool (v1' <=? v2'))
        | Bool _ => None
        | ArrayV _ => None
        | RecordV _ => None
        end
    | Bool _ => None
    | ArrayV _ => None
    | RecordV _ => None
    end
| Greater_Than =>
    match v1 with
    | Undefined => None
    | Int v1' =>
        match v2 with
        | Undefined => None
        | Int v2' => Some (Bool (v1' >? v2'))
        | Bool _ => None
        | ArrayV _ => None
        | RecordV _ => None
        end
    | Bool _ => None
    | ArrayV _ => None
    | RecordV _ => None
    end
| Greater_Than_Or_Equal =>
    match v1 with
    | Undefined => None
    | Int v1' =>
        match v2 with
        | Undefined => None
        | Int v2' => Some (Bool (v1' >=? v2'))
        | Bool _ => None
        | ArrayV _ => None
        | RecordV _ => None
        end
    | Bool _ => None
    | ArrayV _ => None
    | RecordV _ => None
    end
| Plus =>
    match v1 with
    | Undefined => None
    | Int v1' =>
        match v2 with
        | Undefined => None
        | Int v2' => Some (Int (v1' + v2'))
        | Bool _ => None
        | ArrayV _ => None
        | RecordV _ => None
        end
    | Bool _ => None
    | ArrayV _ => None
    | RecordV _ => None
    end
| Minus =>
    match v1 with
    | Undefined => None
    | Int v1' =>
        match v2 with
        | Undefined => None
        | Int v2' => Some (Int (v1' - v2'))
        | Bool _ => None
        | ArrayV _ => None
        | RecordV _ => None
        end
    | Bool _ => None
    | ArrayV _ => None
    | RecordV _ => None
    end
| Multiply =>
    match v1 with
    | Undefined => None
    | Int v1' =>
        match v2 with
        | Undefined => None
        | Int v2' => Some (Int (v1' * v2'))
        | Bool _ => None
        | ArrayV _ => None
        | RecordV _ => None
        end
    | Bool _ => None
    | ArrayV _ => None
    | RecordV _ => None
    end
| Divide =>
    match v1 with
    | Undefined => None
    | Int v1' =>
        match v2 with
        | Undefined => None
        | Int v2' => Some (Int (v1' ÷ v2'))
        | Bool _ => None
        | ArrayV _ => None
        | RecordV _ => None
        end
    | Bool _ => None
    | ArrayV _ => None
    | RecordV _ => None
    end
| Modulus => Math.mod' v1 v2
end.

Lemma binopexp_ok: forall x y z, Math.binary_operation x y z = binopexp x y z .
Proof.
  reflexivity.
Qed.

Lemma unopexp_ok: forall x y, Math.unary_operation x y = unopexp x y.
Proof.
  reflexivity.
Qed.

(* Definition foo := Eval cbv beta delta [bind transl_expr] in transl_expr. *)

Function transl_expr
         (stbl : Symbol_Table_Module.symboltable) (CE : compilenv)
         (e : exp) {struct e} : res expr :=
  match e with
  | Literal _ lit => OK (Econst (transl_literal lit))
  | Name _ (Identifier astnum1 id) =>
      match transl_variable stbl CE astnum1 id with
      | OK x =>
          match fetch_exp_type astnum1 stbl with
          | Some typ => value_at_addr stbl typ x
          | None =>
              Error
                [MSG "transl_expr unknown type at astnum: "; CTX (Pos.of_nat astnum1)]
          end
      | Error msg => Error msg
      end
  | Name _ (IndexedComponent _ _ _) =>
      Error (msg "transl_expr: Array not yet implemented")
  | Name _ (SelectedComponent _ _ _) =>
      Error (msg "transl_expr: record not yet implemented")
  | BinOp _ op e1 e2 =>
      match transl_expr stbl CE e1 with
      | OK x =>
          match transl_expr stbl CE e2 with
          | OK x0 => OK (Ebinop (transl_binop op) x x0)
          | Error msg => Error msg
          end
      | Error msg => Error msg
      end
  | UnOp _ (Unary_Minus as op) e0 =>
      match transl_expr stbl CE e0 with
      | OK x =>
          match transl_unop op with
          | OK x0 => OK (Eunop x0 x)
          | Error msg => Error msg
          end
      | Error msg => Error msg
      end
  | UnOp _ Not e0 =>
      match transl_expr stbl CE e0 with
      | OK x => OK (Ebinop (Ocmp Integers.Ceq) x (Econst (Ointconst Integers.Int.zero)))
      | Error msg => Error msg
      end
  end.

Lemma transl_expr_ok : forall x y z, transl_expr x y z = spark2Cminor.transl_expr x y z.
Proof.
  reflexivity.
Qed.

(* Definition transl_stmt := Eval cbv beta delta [bind bind2 transl_stmt] in transl_stmt. *)

Function transl_stmt (stbl : Symbol_Table_Module.symboltable) (CE : compilenv)
            (e : ast.stmt) {struct e} : res stmt :=
  match e with
  | Null => OK Sskip
  | Assign _ nme e0 =>
      match spark2Cminor.transl_expr stbl CE e0 with
      | OK x =>
          match transl_name stbl CE nme with
          | OK x0 =>
              match compute_chnk stbl nme with
              | OK x1 => OK (Sstore x1 x0 x)
              | Error msg => Error msg
              end
          | Error msg => Error msg
          end
      | Error msg => Error msg
      end
  | If _ e0 s1 s2 =>
      match spark2Cminor.transl_expr stbl CE e0 with
      | OK x =>
          match transl_stmt stbl CE s1 with
          | OK x0 =>
              match transl_stmt stbl CE s2 with
              | OK x1 =>
                  OK
                    (Sifthenelse
                       (Ebinop (Ocmp Integers.Cne) x
                          (Econst (Ointconst Integers.Int.zero))) x0 x1)
              | Error msg => Error msg
              end
          | Error msg => Error msg
          end
      | Error msg => Error msg
      end
  | While _ _ _ => Error (msg "transl_stmt:Not yet implemented")
  | Call _ _ pnum lexp =>
      match transl_params stbl pnum CE lexp with
      | OK x =>
          match transl_procsig stbl pnum with
          | OK (x0, y) =>
              let current_lvl := Datatypes.length CE in
              let addr_enclosing_frame :=
                build_loads_ (Econst (Oaddrstack Integers.Ptrofs.zero)) (current_lvl - y)
                in
              OK
                (Scall None x0
                   (Econst (Oaddrsymbol (transl_procid pnum) (Integers.Ptrofs.repr 0)))
                   (addr_enclosing_frame :: x))
          | Error msg => Error msg
          end
      | Error msg => Error msg
      end
  | Seq _ s1 s2 =>
      match transl_stmt stbl CE s1 with
      | OK x =>
          match transl_stmt stbl CE s2 with
          | OK x0 => OK (Sseq x x0)
          | Error msg => Error msg
          end
      | Error msg => Error msg
      end
  end.

Lemma transl_stmt_ok : forall x y z, transl_stmt x y z = spark2Cminor.transl_stmt x y z.
Proof.
  reflexivity.
Qed.

(* Definition transl_basetype := Eval lazy beta delta [transl_basetype bind] in spark2Cminor.transl_basetype. *)
Function transl_basetype (stbl : Symbol_Table_Module.symboltable) (ty : base_type) {struct ty} :
  res Ctypes.type :=
  match ty with
  | BBoolean => OK (Ctypes.Tint Ctypes.I32 Ctypes.Signed Ctypes.noattr)
  | BInteger _ => OK (Ctypes.Tint Ctypes.I32 Ctypes.Signed Ctypes.noattr)
  | BArray_Type tpcell (Range min max) =>
      match transl_basetype stbl tpcell with
      | OK x => OK (Ctypes.Tarray x (max - min) Ctypes.noattr)
      | Error msg => Error msg
      end
  | BRecord_Type _ => Error (msg "transl_basetype: Not yet implemented!!.")
  end.

Lemma transl_basetype_ok : forall x y, transl_basetype x y = spark2Cminor.transl_basetype x y.
Proof.
  reflexivity.
Qed.

(* Definition transl_typenum := Eval lazy beta delta [transl_typenum bind] in spark2Cminor.transl_typenum. *)
Function transl_typenum (stbl : Symbol_Table_Module.symboltable) (id : typenum) :=
match Symbol_Table_Module.fetch_type id stbl with
| Some t =>
    match type_of_decl t with
    | OK x =>
        match reduce_type stbl x max_recursivity with
        | OK x0 => spark2Cminor.transl_basetype stbl x0
        | Error msg => Error msg
        end
    | Error msg => Error msg
    end
| None => Error (msg "transl_typenum: no such type")
end.

Lemma transl_typenum_ok : forall x y, transl_typenum x y = spark2Cminor.transl_typenum x y.
Proof.
  reflexivity.
Qed.

(* Definition transl_type := Eval lazy iota beta delta [spark2Cminor.transl_type spark2Cminor.transl_basetype bind] in spark2Cminor.transl_type. *)
Function transl_type (stbl : Symbol_Table_Module.symboltable) (t : type) :=
  match t with
  | Boolean => OK (Ctypes.Tint Ctypes.I32 Ctypes.Signed Ctypes.noattr)
  | Integer => OK (Ctypes.Tint Ctypes.I32 Ctypes.Signed Ctypes.noattr)
  | Subtype _ => Error (msg "transl_type: type not treated yet")
  | Derived_Type _ => Error (msg "transl_type: type not treated yet")
  | Integer_Type _ => Error (msg "transl_type: type not treated yet")
  | Array_Type _ => Error (msg "transl_type: type not treated yet")
  | Record_Type _ => Error (msg "transl_type: type not treated yet")
  end.

Lemma transl_type_ok : forall x y, transl_type x y = spark2Cminor.transl_type x y.
Proof.
  reflexivity.
Qed.

(* Definition foo:= Eval lazy beta delta [Memory.Mem.storev] in Memory.Mem.storev. *)
Function cm_storev (chunk : AST.memory_chunk) (m : Memory.Mem.mem) (addr v : Values.val):=
match addr with
| Values.Vundef => None
| Values.Vint _ => None
| Values.Vlong _ => None
| Values.Vfloat _ => None
| Values.Vsingle _ => None
| Values.Vptr b ofs =>
    Memory.Mem.store chunk m b (Integers.Ptrofs.unsigned ofs) v
end.

Lemma cm_storev_ok : forall x y, cm_storev x y = Memory.Mem.storev x y.
Proof.
  reflexivity.
Qed.

(* Definition build_compilenv:= Eval lazy beta iota delta [build_compilenv bind bind2] in build_compilenv. *)
(* using the explicit version because of a bug in Function. *)

Function build_compilenv(stbl : Symbol_Table_Module.symboltable) (enclosingCE : compilenv)
         (_ : Symbol_Table_Module.level) (lparams : list paramSpec)
         (decl : decl) :=
  let stoszchainparam : prod (list (prod idnum OffsetEntry.T)) Z :=
      @pair (list (prod idnum OffsetEntry.T)) Z (@nil (prod idnum OffsetEntry.T))
            (Zpos (xO (xO xH))) in
  match
    build_frame_lparams stbl stoszchainparam lparams
    return (res (prod (list (prod nat CompilEnv.store)) Z))
  with
  | OK x =>
    match
      build_frame_decl stbl x decl
      return (res (prod (list (prod nat CompilEnv.store)) Z))
    with
    | OK p =>
      match p return (res (prod (list (prod nat CompilEnv.store)) Z)) with
      | pair x0 y =>
        let scope_lvl : nat := @Datatypes.length CompilEnv.frame enclosingCE in
        @OK (prod (list (prod nat CompilEnv.store)) Z)
            (@pair (list (prod nat CompilEnv.store)) Z
                   (@cons (prod nat CompilEnv.store)
                          (@pair nat CompilEnv.store scope_lvl x0) enclosingCE) y)
      end
    | Error msg => @Error (prod (list (prod nat CompilEnv.store)) Z) msg
    end
  | Error msg => @Error (prod (list (prod nat CompilEnv.store)) Z) msg
  end.

Lemma build_compilenv_ok : build_compilenv = spark2Cminor.build_compilenv.
Proof.
  reflexivity.
Qed.

(* Definition foo_compute_chk:= Eval lazy beta iota delta [compute_chnk compute_chnk_id compute_chnk_astnum compute_chnk_of_type bind] in compute_chnk. *)

Definition foo_compute_chk:= Eval lazy beta iota delta [compute_chnk compute_chnk_id compute_chnk_astnum compute_chnk_of_type bind] in compute_chnk.

Function compute_chnk (stbl : Symbol_Table_Module.symboltable) (nme : name) :=
match nme with
| Identifier _ id =>
  match fetch_var_type id stbl with
  | OK x =>
    match reduce_type stbl x max_recursivity with
    | OK BBoolean => OK AST.Mint32
    | OK (BInteger _) => OK AST.Mint32
    | OK (BArray_Type _ _) =>
      Error (msg "compute_chnk_of_type: Arrays types not yet implemented!!.")
    | OK (BRecord_Type _) =>
      Error (msg "compute_chnk_of_type: Records types not yet implemented!!.")
    | Error x0 => Error x0
    end
  | Error msg => Error msg
  end
| IndexedComponent _ _ _ => Error (msg "compute_chnk: arrays not implemented yet")
| SelectedComponent _ _ _ => Error (msg "compute_chnk: records not implemented yet")
end.

Lemma compute_chnk_ok : forall x y, compute_chnk x y = spark2Cminor.compute_chnk x y.
Proof.
  reflexivity.
Qed.

(*Definition add_to_frame:= Eval lazy beta iota delta [add_to_frame bind] in add_to_frame. *)

Function add_to_frame (stbl : Symbol_Table_Module.symboltable) (cenv_sz : localframe * Z) (nme : idnum) (subtyp_mrk : type) :=
match cenv_sz return (res (prod CompilEnv.store Z)) with
| pair cenv sz =>
    match compute_size stbl subtyp_mrk return (res (prod (list (prod idnum Z)) Z)) with
    | OK x =>
        let new_size : Z := Z.add sz x in
        match Z.geb new_size Integers.Ptrofs.modulus return (res (prod (list (prod idnum Z)) Z)) with
        | true =>
            @Error (prod (list (prod idnum Z)) Z) (msg "add_to_frame: memory would overflow")
        | false =>
            let new_cenv : list (prod idnum Z) := @cons (prod idnum Z) (@pair idnum Z nme sz) cenv in
            @OK (prod (list (prod idnum Z)) Z) (@pair (list (prod idnum Z)) Z new_cenv new_size)
        end
    | Error msg => @Error (prod (list (prod idnum Z)) Z) msg
    end
end.

Lemma add_to_frame_ok : add_to_frame = spark2Cminor.add_to_frame.
Proof.
  reflexivity.
Qed.

(* Definition compute_size:= Eval lazy beta iota delta [compute_size bind] in compute_size. *)
Function compute_size stbl typ :=  match compute_chnk_of_type stbl typ with
                                     | OK x => OK (size_chunk x)
                                     | Error msg => Error msg
                                     end.
Lemma compute_size_ok : forall stbl typ ,
    compute_size stbl typ = spark2Cminor.compute_size stbl typ.
Proof.
  intros;reflexivity.
Qed.

(* Definition build_frame_lparams:= Eval lazy beta iota delta [build_frame_lparams bind] in build_frame_lparams. *)

Function build_frame_lparams (stbl : Symbol_Table_Module.symboltable) (fram_sz : localframe * Z) (lparam : list paramSpec)
                    {struct lparam} : res (localframe * Z) :=
  match lparam with
  | [ ] => OK fram_sz
  | {| parameter_name := nme; parameter_subtype_mark := subtyp_mrk |} :: lparam' =>
      match spark2Cminor.add_to_frame stbl fram_sz nme subtyp_mrk with
      | OK x => build_frame_lparams stbl x lparam'
      | Error msg => Error msg
      end
  end.

Lemma build_frame_lparams_ok : build_frame_lparams = spark2Cminor.build_frame_lparams.
Proof.
  reflexivity.
Qed.

(* Definition build_frame_decl := Eval lazy beta iota delta [build_frame_decl bind] in build_frame_decl. *)

Function build_frame_decl (stbl : Symbol_Table_Module.symboltable) (fram_sz : localframe * Z)
                 (decl : decl) {struct decl} : res (localframe * Z) :=
  let (fram, sz) := fram_sz in
  match decl with
  | NullDecl => OK fram_sz
  | TypeDecl _ _ => Error (msg "build_frame_decl: type decl no implemented yet")
  | ObjDecl _ objdecl =>
      match spark2Cminor.compute_size stbl (object_nominal_subtype objdecl) with
      | OK x =>
          let new_size := sz + x in
          if new_size >=? Integers.Ptrofs.modulus
          then Error (msg "build_frame_decl: memory would overflow")
          else OK ((object_name objdecl, sz) :: fram, new_size)
      | Error msg => Error msg
      end
  | ProcBodyDecl _ _ => Error (msg "build_frame_decl: proc decl no implemented yet")
  | SeqDecl _ decl1 decl2 =>
      match build_frame_decl stbl fram_sz decl1 with
      | OK x => build_frame_decl stbl x decl2
      | Error msg => Error msg
      end
  end.

Lemma build_frame_decl_ok : build_frame_decl = spark2Cminor.build_frame_decl.
Proof.
  reflexivity.
Qed.

Definition msg1:string := "transl_declaration: D_Type_Declaration not yet implemented".

(* Definition transl_procedure := Eval cbv beta delta [bind bind2 transl_procedure] in transl_procedure. *)

(* We add implicit args to Gfun "(AST.fundef function) unit" to work
   around a limitation of Function *)
Function transl_procedure  (stbl : Symbol_Table_Module.symboltable) (enclosingCE : compilenv)
                 (lvl : Symbol_Table_Module.level) (pbdy : procBodyDecl) {struct pbdy} :
  res CMfundecls :=
  match pbdy with
  | mkprocBodyDecl _ pnum lparams decl0 statm =>
      match spark2Cminor.build_compilenv stbl enclosingCE lvl lparams decl0 with
      | OK (x, y) =>
          if y <=? Integers.Int.max_unsigned
          then
           match transl_declaration stbl x (S lvl) decl0 with
           | OK x0 =>
               match spark2Cminor.transl_stmt stbl x statm with
               | OK x1 =>
                   match init_locals stbl x decl0 with
                   | OK x2 =>
                       match store_params stbl x lparams with
                       | OK x3 =>
                           let chain_param :=
                             Sstore AST.Mint32 (Econst (Oaddrstack Integers.Ptrofs.zero))
                               (Evar chaining_param) in
                           match copy_out_params stbl x lparams with
                           | OK x4 =>
                               let proc_t :=
                                 Sseq chain_param
                                   (Sseq (Sseq x3 (Sseq x2 Sskip)) (Sseq x1 x4)) in
                               match
                                 transl_lparameter_specification_to_procsig stbl lvl
                                   lparams
                               with
                               | OK x5 =>
                                   let tlparams :=
                                     transl_lparameter_specification_to_lident stbl
                                       lparams in
                                   let newGfun :=
                                     (transl_paramid pnum,
                                     @AST.Gfun (AST.fundef function) unit
                                       (AST.Internal
                                          {|
                                          fn_sig := x5;
                                          fn_params := chaining_param :: tlparams;
                                          fn_vars := transl_decl_to_lident stbl decl0;
                                          fn_stackspace := y;
                                          fn_body := proc_t |})) in
                                   OK (newGfun :: x0)
                               | Error msg => Error msg
                               end
                           | Error msg => Error msg
                           end
                       | Error msg => Error msg
                       end
                   | Error msg => Error msg
                   end
               | Error msg => Error msg
               end
           | Error msg => Error msg
           end
          else Error (msg "spark2Cminor: too many local variables, stack size exceeded")
      | Error msg => Error msg
      end
  end
with
transl_declaration (stbl : Symbol_Table_Module.symboltable)
                   (enclosingCE : compilenv) (lvl : Symbol_Table_Module.level)
                   (decl : decl) {struct decl} : res CMfundecls :=
  match decl with
  | NullDecl => OK [ ]
  | TypeDecl _ _ => Error (msg "transl_declaration: TypeDecl not yet implemented")
  | ObjDecl _ objdecl =>
      OK
        [(transl_paramid (object_name objdecl),
         AST.Gvar
           {|
           AST.gvar_info := tt;
           AST.gvar_init := [ ];
           AST.gvar_readonly := false;
           AST.gvar_volatile := false |})]
  | ProcBodyDecl _ pbdy => transl_procedure stbl enclosingCE lvl pbdy
  | SeqDecl _ decl1 decl2 =>
      match transl_declaration stbl enclosingCE lvl decl1 with
      | OK x =>
          match transl_declaration stbl enclosingCE lvl decl2 with
          | OK x0 => OK (x ++ x0)
          | Error msg => Error msg
          end
      | Error msg => Error msg
      end
  end.

Functional Scheme transl_procedure_ind2 := Induction for transl_procedure Sort Prop
with transl_declaration_ind2 := Induction for transl_declaration Sort Prop.

Lemma transl_declaration_ok : transl_declaration = spark2Cminor.transl_declaration.
Proof.
  reflexivity.
Qed.

Lemma transl_procedure_ok : transl_procedure = spark2Cminor.transl_procedure.
Proof.
  reflexivity.
Qed.

(* Definition xxx := Eval cbv beta delta [bind transl_procsig] in transl_procsig. *)
Function transl_procsig (stbl : Symbol_Table_Module.symboltable) (pnum : procnum) :=
  match fetch_proc pnum stbl with
  | Some (lvl, pdecl) =>
    match transl_lparameter_specification_to_procsig stbl lvl (procedure_parameter_profile pdecl) with
    | Errors.OK x => Errors.OK (x, lvl)
    | Error msg => Error msg
    end
  | None => Error (msg "Unkonwn procedure")
  end.

Lemma transl_procsig_ok: forall stbl pnum, transl_procsig stbl pnum = spark2Cminor.transl_procsig stbl pnum.
Proof.
  reflexivity.
Qed.

(* Definition copy_out_params:= Eval lazy beta iota delta [copy_out_params bind] in copy_out_params. *)
Function copy_out_params  (stbl : Symbol_Table_Module.symboltable) (CE : compilenv)
                (lparams : list paramSpec) {struct lparams} :
res stmt :=
  match lparams with
  | [ ] => OK Sskip
  | prm :: lparams' =>
      let id := transl_paramid (parameter_name prm) in
      match spark2Cminor.compute_chnk stbl (Identifier 0%nat (parameter_name prm)) with
      | OK x =>
          match copy_out_params stbl CE lparams' with
          | OK x0 =>
              match transl_name stbl CE (Identifier 0%nat (parameter_name prm)) with
              | OK x1 =>
                  match parameter_mode prm with
                  | In => OK x0
                  | Out => OK (Sseq (Sstore x (Evar id) (Eload x x1)) x0)
                  | In_Out => OK (Sseq (Sstore x (Evar id) (Eload x x1)) x0)
                  end
              | Error msg => Error msg
              end
          | Error msg => Error msg
          end
      | Error msg => Error msg
      end
  end.

Lemma copy_out_params_ok : forall stbl CE lparams, copy_out_params stbl CE lparams = spark2Cminor.copy_out_params stbl CE lparams.
Proof.
  reflexivity.
Qed.

(* Definition store_params:= Eval lazy beta iota delta [store_params bind] in store_params. *)

(* We hide the parameter_mode stuff, for convenience in proofs. *)

Definition indirection_according_to_mode mode x id :=
  match mode with
  | In => Evar id
  | Out => Eload x (Evar id)
  | In_Out => Eload x (Evar id)
  end .

Definition build_param_copyin_assign mode addr x id :=
  match mode with
  | Out => Sskip
  | _ => Sstore x addr (indirection_according_to_mode mode x id)
  end.

Function store_params (stbl : symboltable) (CE : compilenv) (lparams : list paramSpec) {struct lparams} : res stmt :=
  match lparams with
  | [ ] => OK Sskip
  | prm :: lparams' =>
      let id := transl_paramid (parameter_name prm) in
      match spark2Cminor.compute_chnk stbl (Identifier 0%nat (parameter_name prm)) with
      | OK x =>
          match store_params stbl CE lparams' with
          | OK x0 =>
              match transl_name stbl CE (Identifier 0%nat (parameter_name prm)) with
              | OK x1 =>
                  let stmt0 := build_param_copyin_assign (parameter_mode prm) x1 x id in
                  OK (Sseq stmt0 x0)
              | Error msg => Error msg
              end
          | Error msg => Error msg
          end
      | Error msg => Error msg
      end
  end.

Lemma store_params_ok : forall stbl CE lparams, store_params stbl CE lparams = spark2Cminor.store_params stbl CE lparams.
Proof.
  intros until lparams.
  unfold spark2Cminor.store_params.
  !functional induction store_params stbl CE lparams;try fold spark2Cminor.store_params in *;auto.
  all:rewrite heq_compute_chnk.
  all:try rewrite <- heq_store_params0.
  all:try rewrite heq_store_params.
  all: try rewrite heq_transl_name.
  all:simpl;auto.
  unfold build_param_copyin_assign.
  unfold indirection_according_to_mode.
  destruct (parameter_mode prm);auto.
Qed.

(* Definition init_locals:= Eval lazy beta iota delta [init_locals bind] in init_locals. *)
Function init_locals (stbl : Symbol_Table_Module.symboltable) (CE : compilenv)
            (decl : decl) {struct decl} : res stmt :=
  match decl with
  | NullDecl => OK Sskip
  | TypeDecl _ _ => OK Sskip
  | ObjDecl _ objdecl =>
      match initialization_exp objdecl with
      | Some e =>
          match
            spark2Cminor.compute_chnk stbl (Identifier 0%nat (object_name objdecl))
          with
          | OK x =>
              match spark2Cminor.transl_expr stbl CE e with
              | OK x0 =>
                  match
                    transl_name stbl CE (Identifier 0%nat (object_name objdecl))
                  with
                  | OK x1 => OK (Sstore x x1 x0)
                  | Error msg => Error msg
                  end
              | Error msg => Error msg
              end
          | Error msg => Error msg
          end
      | None => OK Sskip
      end
  | ProcBodyDecl _ _ => OK Sskip
  | SeqDecl _ decl1 decl2 =>
      match init_locals stbl CE decl1 with
      | OK x =>
          match init_locals stbl CE decl2 with
          | OK x0 => OK (Sseq x x0)
          | Error msg => Error msg
          end
      | Error msg => Error msg
      end
  end.

Lemma init_locals_ok : forall stbl CE decl, init_locals stbl CE decl = spark2Cminor.init_locals stbl CE decl.
Proof.
  reflexivity.
Qed.

Function eval_constant (ge : genv) (sp : Values.val) (cst : constant) :=
match cst with
| Ointconst n => Some (Values.Vint n)
| Ofloatconst n => Some (Values.Vfloat n)
| Osingleconst n => Some (Values.Vsingle n)
| Olongconst n => Some (Values.Vlong n)
| Oaddrsymbol s ofs => Some (Globalenvs.Genv.symbol_address ge s ofs)
| Oaddrstack ofs => Some (Values.Val.offset_ptr sp ofs)
end.

Lemma eval_constant_ok : forall ge sp cst, eval_constant ge sp cst = Cminor.eval_constant ge sp cst.
Proof.
  reflexivity.
Qed.

Function add v1 v2 :=
match v1 with
| Values.Vundef => Values.Vundef
| Values.Vint n1 =>
    match v2 with
    | Values.Vundef => Values.Vundef
    | Values.Vint n2 => Values.Vint (Integers.Int.add n1 n2)
    | Values.Vlong _ => Values.Vundef
    | Values.Vfloat _ => Values.Vundef
    | Values.Vsingle _ => Values.Vundef
    | Values.Vptr b2 ofs2 =>
        if Archi.ptr64
        then Values.Vundef
        else Values.Vptr b2 (Integers.Ptrofs.add ofs2 (Integers.Ptrofs.of_int n1))
    end
| Values.Vlong _ => Values.Vundef
| Values.Vfloat _ => Values.Vundef
| Values.Vsingle _ => Values.Vundef
| Values.Vptr b1 ofs1 =>
    match v2 with
    | Values.Vundef => Values.Vundef
    | Values.Vint n2 =>
        if Archi.ptr64
        then Values.Vundef
        else Values.Vptr b1 (Integers.Ptrofs.add ofs1 (Integers.Ptrofs.of_int n2))
    | Values.Vlong _ => Values.Vundef
    | Values.Vfloat _ => Values.Vundef
    | Values.Vsingle _ => Values.Vundef
    | Values.Vptr _ _ => Values.Vundef
    end
end.

Lemma add_ok : forall x y, add x y = Values.Val.add x y.
Proof.
  reflexivity.
Qed.

(* Definition transl_paramexprlist := Eval cbv beta delta [bind bind2 transl_paramexprlist] in transl_paramexprlist. *)

Function transl_paramexprlist (stbl : symboltable) (CE : compilenv) (el : list exp) (lparams : list paramSpec) {struct el} :
  res (list expr) :=
  let (l, l0) := (el, lparams) in
  match l with
  | nil => match l0 with
           | nil => Errors.OK nil
           | _ :: _ => Error (msg "Bad number of arguments")
           end
  | e1 :: e2 =>
      match l0 with
      | nil => Error (msg "Bad number of arguments")
      | p1 :: p2 =>
          match parameter_mode p1 with
          | In =>
              match spark2Cminor.transl_expr stbl CE e1 with
              | Errors.OK x => match transl_paramexprlist stbl CE e2 p2 with
                        | Errors.OK x0 => Errors.OK (x :: x0)
                        | Error msg => Error msg
                        end
              | Error msg => Error msg
              end
          | Out =>
              match e1 with
              | Literal _ _ => Error (msg "Out or In Out parameters should be names")
              | Name _ nme =>
                  match transl_name stbl CE nme with
                  | Errors.OK x => match transl_paramexprlist stbl CE e2 p2 with
                            | Errors.OK x0 => Errors.OK (x :: x0)
                            | Error msg => Error msg
                            end
                  | Error msg => Error msg
                  end
              | BinOp _ _ _ _ => Error (msg "Out or In Out parameters should be names")
              | UnOp _ _ _ => Error (msg "Out or In Out parameters should be names")
              end
          | In_Out =>
              match e1 with
              | Literal _ _ => Error (msg "Out or In Out parameters should be names")
              | Name _ nme =>
                  match transl_name stbl CE nme with
                  | Errors.OK x => match transl_paramexprlist stbl CE e2 p2 with
                            | Errors.OK x0 => Errors.OK (x :: x0)
                            | Error msg => Error msg
                            end
                  | Error msg => Error msg
                  end
              | BinOp _ _ _ _ => Error (msg "Out or In Out parameters should be names")
              | UnOp _ _ _ => Error (msg "Out or In Out parameters should be names")
              end
          end
      end
  end.

Import Ctypes.
Lemma transl_paramexprlist_ok : forall x y z, transl_paramexprlist x y z = spark2Cminor.transl_paramexprlist x y z.
Proof.
  reflexivity.
Qed.

Function access_mode ty :=
match ty with
| Ctypes.Tvoid => Ctypes.By_nothing
| Ctypes.Tint I8 Signed _ => Ctypes.By_value AST.Mint8signed
| Ctypes.Tint I8 Unsigned _ => Ctypes.By_value AST.Mint8unsigned
| Ctypes.Tint I16 Signed _ => Ctypes.By_value AST.Mint16signed
| Ctypes.Tint I16 Unsigned _ => Ctypes.By_value AST.Mint16unsigned
| Ctypes.Tint I32 _ _ => Ctypes.By_value AST.Mint32
| Ctypes.Tint IBool _ _ => Ctypes.By_value AST.Mint8unsigned
| Ctypes.Tlong _ _ => Ctypes.By_value AST.Mint64
| Ctypes.Tfloat F32 _ => Ctypes.By_value AST.Mfloat32
| Ctypes.Tfloat F64 _ => Ctypes.By_value AST.Mfloat64
| Ctypes.Tpointer _ _ => Ctypes.By_value AST.Mptr
| Ctypes.Tarray _ _ _ => Ctypes.By_reference
| Ctypes.Tfunction _ _ _ => Ctypes.By_reference
| Ctypes.Tstruct _ _ => Ctypes.By_copy
| Ctypes.Tunion _ _ => Ctypes.By_copy
end.

Lemma access_mode_ok : forall ty, Ctypes.access_mode ty = access_mode ty.
Proof.
  reflexivity.
Qed.


From Tealeaves Require Export
  Classes.Monoid
  Classes.Decorated.Functor
  Classes.Decorated.Monad
  Classes.Setlike.Functor
  Classes.Setlike.Monad
  Functors.Sets
  Data.Strength.

Import Monoid.Notations.
Import Setlike.Functor.Notations.

#[local] Generalizable Variables W A F.

(** * Decorated set-like functors *)
(******************************************************************************)

(** ** Derived operation [tosetd] *)
(******************************************************************************)
#[export] Instance Tosetd_cat `{Toset F} `{Decorate W F} : Tosetd F W :=
  fun A => toset F ∘ dec F.

(** ** Utility lemmas for [shift] *)
(******************************************************************************)
Section shift_utility_lemmas.

  Context
    (F : Type -> Type)
    `{SetlikeFunctor F}
    `{Monoid W}.

  Theorem in_shift_iff {A} : forall w w1 a (t : F (W * A)),
      (w, a) ∈ shift F (w1, t) <->
      exists w2, (w2, a) ∈ t /\ w = w1 ● w2.
  Proof.
    introv. unfold shift, compose, strength.
    rewrite (in_fmap_iff F). split.
    - intros [ [w1' [w2' a']] [hin heq]].
      rewrite (in_fmap_iff F) in hin.
      destruct hin as [ [w_ a_] [hin' heq']].
      inverts heq'. inverts heq. now (exists w2').
    - intros [w2 [? ?]]. exists (w1, (w2, a)).
      rewrite (in_fmap_iff F). subst. split.
      + now (exists (w2, a)).
      + reflexivity.
  Qed.

  Theorem in_shift_mono {A} : forall w1 w2 a (t : F (W * A)),
      (w1, a) ∈ t -> (w2 ● w1, a) ∈ shift F (w2, t).
  Proof.
    introv. unfold shift, compose, strength.
    rewrite (in_fmap_iff F). exists (w2, (w1, a)).
    rewrite (in_fmap_iff F). split.
    - now (exists (w1, a)).
    - easy.
  Qed.

End shift_utility_lemmas.

(** ** Utility lemmas for [toset] and [tosetd] *)
(******************************************************************************)
Section tosetd_utility_lemmas.

  Context
    (F : Type -> Type)
    `{SetlikeFunctor F}
    `{Monoid W}
    `{Decorate W F}
    `{! DecoratedFunctor W F}
    {A : Type}.

  Implicit Types (w : W) (a : A) (t : F A).

  Theorem in_in_extract : forall w a (t : F (W * A)),
      (w, a) ∈ t -> a ∈ fmap F (extract (prod W)) t.
  Proof.
    introv hyp. apply (in_fmap_iff F). now exists (w, a).
  Qed.

  Theorem in_of_ind : forall w a t,
      (w, a) ∈d t -> a ∈ t.
  Proof.
    introv hyp. replace t with (fmap F (extract (prod W)) (dec F t)).
    rewrite (in_fmap_iff F). now (exists (w, a)).
    compose near t on left.
    now rewrite (dfun_dec_extract W F).
  Qed.

  Theorem ind_of_in : forall t a,
      a ∈ t <-> exists w, (w, a) ∈d t.
  Proof.
    introv. split; intro hyp.
    - replace t with (fmap F (extract (prod W)) (dec F t)) in hyp
        by (now compose near t on left; rewrite (dfun_dec_extract W F)).
      rewrite (in_fmap_iff F) in hyp. destruct hyp as [[w ?] [? heq]].
      inverts heq. now (exists w).
    - destruct hyp as [? hyp]. now apply in_of_ind in hyp.
  Qed.

End tosetd_utility_lemmas.

(** * Notations *)
(******************************************************************************)
Section decorated_setlike_properties.

  Context
    (T : Type -> Type)
    `{Monoid W}
    `{Fmap T} `{Return T} `{Join T} `{Decorate W T} `{Toset T}
    `{! DecoratedMonad W T}
    `{! SetlikeMonad T}.

  Theorem ind_ret_iff {A} : forall w (a a' : A),
      (w, a') ∈d ret T a <-> w = Ƶ /\ a' = a.
  Proof.
    introv. unfold_ops @Tosetd_cat. unfold tosetd, compose.
    compose near a on left.
    rewrite (dmon_ret W T). unfold compose.
    rewrite (in_ret_iff T). now rewrite pair_equal_spec.
  Qed.

End decorated_setlike_properties.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
Require Import securite.

Lemma POinvprel7 :
 forall (l l0 : list C) (k k0 k1 k2 : K) (c c0 c1 c2 : C)
   (d d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19
    d20 : D),
 inv0
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l) ->
 inv1
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l) ->
 invP
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l) ->
 rel7
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l)
   (ABSI (MBNaKab d18 d19 d20 k2) (MANbKabCaCb d15 d16 d17 k1 c1 c2)
      (MABNaNbKeyK d10 d11 d12 d13 d14) l0) ->
 invP
   (ABSI (MBNaKab d18 d19 d20 k2) (MANbKabCaCb d15 d16 d17 k1 c1 c2)
      (MABNaNbKeyK d10 d11 d12 d13 d14) l0).

Proof.
do 32 intro.
unfold inv0, invP, rel7 in |- *; intros know_c_c0_l Inv1 know_Kab and1.
elim know_c_c0_l; intros know_c_l know_c0_l.
elim and1; intros eq_l0 t1.
clear know_c_c0_l Inv1 and1 t1.
rewrite eq_l0.
apply D2.
simpl in |- *.
repeat apply C2 || apply C3 || apply C4.
apply equivncomp with (l ++ rngDDKKeyABminusKab).
apply AlreadyIn; apply EP0; assumption.
apply D1; assumption.
discriminate.
discriminate.
Qed.


(** Beginning of the file for GV typing lemmas. *)
Require Import Metatheory.
Require Import GV_Definitions GV_Infrastructure.
Set Implicit Arguments.

(* Destruct compound well-formed type assumptions. *)
Ltac des_wfs :=
  match goal with
    | [H: wf_typ (! _ # _) _ |- _] => inverts H
    | [H: wf_typ (? _ # _) _ |- _] => inverts H
    | [H: wf_typ (_ <+> _) _ |- _] => inverts H
    | [H: wf_typ (_ <&> _) _ |- _] => inverts H
    | [H: wf_typ (_ <x> _) _ |- _] => inverts H
    | [H: wf_typ (_ ⊸ _) _ |- _] => inverts H
    | [H: wf_typ (_ ⟶ _) _ |- _] => inverts H
    | |- _ => idtac
  end.

Lemma duals_are_sessions:
  forall S dS (DU: are_dual S dS),
    is_session S /\ is_session dS.
Proof. ii; induction DU; des; split; auto. Qed.

Lemma duals_are_wf:
  forall S dS (DU: are_dual S dS),
    wf_typ S lin /\ wf_typ dS lin.
Proof.
  ii; induction DU; des; split; auto; econstructor; eauto
  ; by repeat match goal with
                | [H: are_dual ?S ?dS |- _] =>
                  apply duals_are_sessions in H; des; auto
              end.
Qed.

Lemma wt_tm_is_lc:
  forall Φ t T
         (WT: Φ ⊢ t ∈ T),
    lc t.
Proof.
  ii; induction WT; des_wfs; match goal with
                               | [H: are_dual ?S ?dS |- _] =>
                                 apply duals_are_wf in H; des
                               | |- _ => idtac
                             end; eauto using subst_lc.
Qed.

Lemma gv_in_env_fv_1:
  forall Φ M T x
         (WT: Φ ⊢ M ∈ T)
         (IN: x `in` dom Φ),
    x `in` GVFV M.
Proof.
  ii; induction WT; try (by s; simpl_env in *; destruct_in; auto).
  - pick fresh y; destruct_notin; find_specializes; s; des.
    simpl_env in *; destruct_in; apply open_fv_proc_1 in H; auto.
  - pick fresh y; pick fresh z; destruct_notin.
    apply notin_singleton_2 in NotInTac1.
    forwards NIN: notin_union_3 Fr0 NotInTac1.
    specializes H Fr NIN.
    simpl_env in *; destruct_in; s; [fsetdec|].
    do 2 !apply open_fv_proc_1 in H; auto.
  - pick fresh y; destruct_notin; find_specializes; s.
    simpl_env in *; destruct_in; auto.
    apply open_fv_proc_1 in H; auto.
  - pick fresh y; destruct_notin; find_specializes; s.
    simpl_env in *; destruct_in; solve [apply open_fv_proc_1 in H; auto
                                       |apply open_fv_proc_1 in H0; auto].
Qed.


(** * Functors between [set_cat] and [prop_cat] *)
Require Import Category.Core Functor.Core SetCategory.Core.
Require Import Basics.Trunc HProp HSet TruncType.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Section set_coercions_definitions.
  Context `{Funext}.

  Variable C : PreCategory.

  Definition to_prop := Functor C prop_cat.
  Definition to_set := Functor C set_cat.

  Definition from_prop := Functor prop_cat C.
  Definition from_set := Functor set_cat C.
End set_coercions_definitions.

Identity Coercion to_prop_id : to_prop >-> Functor.
Identity Coercion to_set_id : to_set >-> Functor.
Identity Coercion from_prop_id : from_prop >-> Functor.
Identity Coercion from_set_id : from_set >-> Functor.

Section set_coercions.
  Context `{Funext}.

  Variable C : PreCategory.

  (** ** Functors to [prop_cat] give rise to functors to [set_cat] *)
  Definition to_prop2set (F : to_prop C) : to_set C :=
    Build_Functor C set_cat
                  (fun x => BuildhSet (F x))
                  (fun s d m => (F _1 m)%morphism)
                  (fun s d d' m m' => composition_of F s d d' m m')
                  (fun x => identity_of F x).

  (** ** Functors from [set_cat] give rise to functors to [prop_cat] *)
  Definition from_set2prop (F : from_set C) : from_prop C
    := Build_Functor prop_cat C
                     (fun x => F (BuildhSet x))
                     (fun s d m => (F _1 (m : morphism
                                                set_cat
                                                (BuildhSet s)
                                                (BuildhSet d)))%morphism)
                     (fun s d d' m m' => composition_of F
                                                        (BuildhSet s)
                                                        (BuildhSet d)
                                                        (BuildhSet d')
                                                        m
                                                        m')
                     (fun x => identity_of F (BuildhSet x)).
End set_coercions.


(* This module defines the big-step operational semantics (cf. Figure
5 in the paper). *)

From Rattus Require Export TypingClosed Worlds.

From Rattus Require Import Tactics.

From Coq Require Import Program.Equality  Omega.

Reserved Notation " '{' t ',' h '}' '⇓' '{' t' ','  h' '}' " (at level 40).
Inductive red : term -> store -> term -> store -> Prop :=
(* Value reductions *)
| red_value v h : isvalue v ->
    {v,h} ⇓ {v,h}
(* Expression reductions *)
| red_pair     : forall (t1 t2 v1 v2 : term) (h h' h'' : store),
    {t1,h} ⇓ {v1,h'} ->
    {t2,h'} ⇓ {v2,h''} ->
    {pair t1 t2,h} ⇓ {pair v1 v2, h''}
| red_add     : forall (t1 t2 : term) (h h' h'' : store) n m,
    {t1,h} ⇓ {natlit n,h'} ->
    {t2,h'} ⇓ {natlit m,h''} ->
    {add t1 t2,h} ⇓ {natlit (n+m), h''}
| red_pr1       : forall (t v1 v2 : term) (h h' : store),
    {t,h} ⇓ {pair v1 v2,h'} ->
    {pr1 t, h} ⇓ {v1,h'}
| red_pr2       : forall (t v1 v2 : term) (h h' : store),
    {t,h} ⇓ {pair v1 v2,h'} ->
    {pr2 t, h} ⇓ {v2,h'}
| red_in1      : forall (t v : term) (h h' : store),
    {t,h} ⇓ {v,h'} ->
    {in1 t,h} ⇓ {in1 v,h'}
| red_in2      : forall (t v : term) (h h' : store),
    {t,h} ⇓ {v,h'} ->
    {in2 t,h} ⇓ {in2 v,h'}
| red_case1     : forall (t t1 t2 v v' : term) (h h' h'' : store),
    {t,h} ⇓ {in1 v, h'} ->
    {sub_term t1 v , h'} ⇓ {v',h''} ->
    {case t t1 t2, h} ⇓ {v',h''}
| red_case2     : forall (t t1 t2 v v' : term) (h h' h'' : store),
    {t,h} ⇓ {in2 v, h'} ->
    {sub_term t2 v,h'} ⇓ {v',h''} ->
    {case t t1 t2, h} ⇓ {v',h''}
| red_app t t' t'' v v' h h' h'' h''' :
    {t,h} ⇓ {abs t'',h'} ->
    {t',h'} ⇓ {v,h''} ->
    {sub_term t'' v,h''} ⇓ {v',h'''} ->
    {app t t',h} ⇓ {v',h'''}
| red_letin t t' v v' h h' h'' :
    {t,h} ⇓ {v,h'} ->
    {sub_term t' v,h'} ⇓ {v',h''} ->
    {letin t t',h} ⇓ {v',h''}
| red_delay t h h' :
    {delay t, (h', h) } ⇓ {ref (alloc_fresh h), (h', heap_cons h (alloc_fresh h) t)}
| red_adv t t' v l hn he he' h:
    {t,(None, he)} ⇓ {ref l, (None, he')}  ->
    heap_mapsto l t' he' ->
    {t', (Some he', hn)} ⇓ {v,h}  ->
    {adv t, (Some he, hn)} ⇓ {v,h}
| red_unbox_box t t' v s s' s'' :
    {t,s} ⇓ {box t',s'} ->
    {t', s'} ⇓ {v,s''} ->
    {unbox t,s} ⇓ {v,s''}
| red_fix t v s s' :
    {sub_term t (box (delay (fixp t))), s} ⇓ {v,s'} ->
    {fixp  t, s} ⇓ {v,s'}
| red_into       : forall h h' t v,
    {t,h} ⇓ {v,h'} ->
    {into t,h} ⇓ {into v,h'}
| red_out        : forall h h' t v,
    {t,h} ⇓ {into v,h'} ->
    {out t,h} ⇓ {v,h'}
where  " '{' t ',' h '}' '⇓' '{' t' ','  h' '}' " := (red t h t' h').

#[global] Hint Constructors red : core.

Lemma red_extensive t t' h h' : red t h t' h' -> store_le h h'.
Proof.
  intros R. induction R;eauto using store_le_trans.
  - destruct h'; constructor; eauto using heap_cons_mono,heap_fresh_alloc.
  - inversion IHR1. subst. inversion IHR2. subst.
    eauto using heap_le_trans.
Qed.

Lemma red_closed t t' s s' : closed_term t -> closed_store s -> red t s t' s' -> closed_term t' /\ closed_store s'.
Proof.
  intros C CS R. induction R;try solve[eauto; constructor;inversion C; subst; eauto].
  - (* pair *)
    inversion C; subst. apply IHR1 in H2; auto.
    destruct H2 as [IH1F IH1C]. apply IHR2 in H3;auto.
    destruct H3 as [IH2F IH2C]. eauto.
  - (* add *)
    inversion C; subst. apply IHR1 in H2; auto.
    destruct H2 as [IH1F IH1C]. apply IHR2 in H3;auto.
    destruct H3 as [IH2F IH2C]. eauto.
  - (* pr1 *)
    inversion C; subst. apply IHR in H1.
    destruct H1 as [IHF IHC].
    inversion IHF;auto. auto.
  - (* pr2 *)
    inversion C; subst. apply IHR in H1.
    destruct H1 as [IHF IHC].
    inversion IHF;auto. auto.
  - (* in1 *)
    inversion C; subst. apply IHR in H1;auto.
    destruct H1 as [IHF IHC]. eauto.
  - (* in2 *)
    inversion C; subst. apply IHR in H1;auto.
    destruct H1 as [IHF IHC]. eauto.
  - (* case in1 *)
    inversion C; subst. apply IHR1 in H3;auto.
    destruct H3 as [IH1F IH1C].
    dependent destruction IH1F. apply IHR2 in IH1C;auto.
    apply sub_term_closed;auto.
  - (* case in2 *)
    inversion C; subst. apply IHR1 in H3;auto.
    destruct H3 as [IH1F IH1C].
    dependent destruction IH1F. apply IHR2 in IH1C;auto.
    apply sub_term_closed;auto.
  - (* app *)
    dependent destruction C.
    apply IHR1 in C1;auto.
    destruct C1 as [IH1F IH1C].
    apply IHR2 in C2;auto.
    destruct C2 as [IH2F IH2C].
    apply IHR3 in IH2C;auto.
    dependent destruction IH1F.
    apply sub_term_closed;auto.
  - dependent destruction C.
    apply IHR1 in C1;auto.
    destruct C1 as [IH1F IH1C].
    apply IHR2;auto using sub_term_closed.
  - (* delay *)
    split. auto. dependent destruction C.
    dependent destruction CS;constructor;eauto using closed_heap_alloc.
  - (* adv *)
    inversion C; subst. inversion CS;subst. apply IHR1 in H2;auto.
    destruct H2 as [IH1F IH1C]. inversion IH1C;subst. apply H1 in H.
    apply IHR2 in H;auto.
  - (* unbox box *)
    dependent destruction C. apply IHR1 in C;auto.
    destruct C as [IH1F IH1C]. dependent destruction IH1F.
    eauto.
  - (* fixp *)
    dependent destruction C. apply IHR.
    + apply sub_term_closed;auto.
    + dependent destruction CS; constructor;eauto using closed_heap_alloc.
  - (* into *)
    dependent destruction C. apply IHR in C;auto.
    destruct C as [IHF IHC]. eauto.
  - (* out *)
    dependent destruction C. apply IHR in C;auto.
    destruct C as [IHF IHC]. dependent destruction IHF. eauto.
Qed.

Lemma red_closed_term t t' s s' : closed_term t -> closed_store s -> red t s t' s'
                                  -> closed_term t'.
Proof.
  intros T S R. eapply red_closed in R; autodest.
Qed.

Lemma red_closed_store t t' s s' : closed_term t -> closed_store s -> red t s t' s'
                             -> closed_store s'.
Proof.
  intros T S R. eapply red_closed in R; autodest.
Qed.

Lemma red_isvalue_id v v' s s' : isvalue v -> red v s v' s' -> v = v' /\ s = s'.
Proof.
  intros V R. generalize dependent v'. generalize dependent s. generalize dependent s'.
  induction V;intros;inversion R;subst; eauto.
  - apply IHV in H0. autodest.
  - apply IHV1 in H1. apply IHV2 in H5. autodest.
  - apply IHV in H0. autodest.
  - apply IHV in H0. autodest.
Qed.

Ltac inv_value := match goal with
                  | [H : isvalue _ |- _] => inversion H;subst
                  | _ => subst
                  end.

Lemma red_determ t s t1 t2 s1 s2 : red t s t1 s1 -> red t s t2 s2 -> t1 = t2 /\ s1 = s2.
Proof.
  intros R1. generalize dependent t2. generalize dependent s2. induction R1;intros s_2 t_2 R2.
  - eauto using red_isvalue_id.
  - inversion R2;subst. inversion H.
    + subst. eapply red_value in H2. eapply red_value in H3.
      apply IHR1_1 in H2. apply IHR1_2 in H3. autodest.
    + apply IHR1_1 in H1. autodest. apply IHR1_2 in H5. autodest.
  - inversion R2;subst. inversion H.
    apply IHR1_1 in H1. autodest. apply IHR1_2 in H5. autodest.
    inversion H0. inversion H. subst. eauto.
  - dependent destruction R2. inv_value. apply IHR1 in R2. autodest.
    inversion H. subst. auto.
  - dependent destruction R2. inv_value. apply IHR1 in R2. autodest.
    inversion H. subst. auto.
  - dependent destruction R2; inv_value.  eapply red_value in H1. eapply IHR1 in H1. autodest.
    apply IHR1 in R2. autodest.
  - dependent destruction R2. inv_value.  eapply red_value in H1. eapply IHR1 in H1. autodest.
    apply IHR1 in R2. autodest.
  - dependent destruction R2; inv_value.
    + apply IHR1_1 in R2_1. autodest. inversion H. subst.
      apply IHR1_2 in R2_2. autodest.
    + apply IHR1_1 in R2_1. autodest. inversion H.
  - dependent destruction R2; inv_value.
    + apply IHR1_1 in R2_1. autodest. inversion H.
    + apply IHR1_1 in R2_1. autodest. inversion H. subst.
      apply IHR1_2 in R2_2. autodest.
  - dependent destruction R2; inv_value.
    apply IHR1_1 in R2_1. autodest. inversion H. subst.
    apply IHR1_2 in R2_2. autodest.
  - dependent destruction R2; inv_value.
    apply IHR1_1 in R2_1. autodest.
  - dependent destruction R2; inv_value. auto.
  - dependent destruction R2; inv_value.
    apply IHR1_1 in R2_1. autodest. inversion H1. inversion H2. subst.
    eapply heap_mapsto_determ in H;eauto. subst.
    apply IHR1_2 in R2_2. autodest.
  - dependent destruction R2; inv_value.
    apply IHR1_1 in R2_1. autodest. inversion H. subst. auto.
  - dependent destruction R2; inv_value.
    apply IHR1 in R2. autodest.
  - dependent destruction R2; inv_value.
    + eapply red_value in H1. apply IHR1 in H1. autodest.
    + apply IHR1 in R2. autodest.
  - dependent destruction R2; inv_value.
    apply IHR1 in R2. autodest. inversion H. subst. auto.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(* -----                          log2_spec.v                          ---- *)

(*                                                                          *)
(* Author: Pierre Casteran.                                                 *)
(*    LABRI, URA CNRS 1304,                                                 *)
(*    Departement d'Informatique, Universite Bordeaux I,                    *)
(*    33405 Talence CEDEX,                                                  *)
(*    e-mail:  casteran@labri.u-bordeaux.fr                                 *)

Require Import Arith.
Require Import Peano_dec.
Require Import Constants.
Require Import Mult_compl.
Require Import Wf_nat.
Require Import euclid.
Require Import Le_lt_compl.
Require Import shift.
Require Import Compare_dec.
Require Import two_power.

(* specification of logarithm (base 2) *)
(***************************************)
Definition log2_spec (n0 : nat) :=
  {l : nat &
  {n0 = two_power l} + {two_power l < n0 /\ n0 < two_power (S l)}}.

Section applications.
 Variable log2 : forall n : nat, 0 < n -> log2_spec n.

 (* logarithm by excess *)
 (***********************)

 Lemma ceiling_log2 :
  forall n : nat,
  one < n -> {l : nat | two_power (pred l) < n /\ n <= two_power l}.

 (**********************************************)
 Proof.
 refine
  (fun n _ =>
   match log2 n _ with
   | existS l b =>
       match b with
       | left e => exist _ l _
       | right a => exist _ (S l) _
       end
   end).
 auto with arith.
(*
 Realizer [n:nat]<nat>let (l:nat;b:bool)=(log2 n)
           in <nat> if b then l else (S l).
  Program_all.
*)
  rewrite e; split.
  apply two_power_mono.
  cut (0 < l).
  generalize l; induction  l as [| l Hrecl]; auto with arith.
  case (lt_or_Zero l); [ auto with arith | intro eg ].
  absurd (one < n);
   [ rewrite e; rewrite eg; simpl in |- *; auto with arith
   | auto with arith ].
  auto with arith.
  unfold pred in |- *; elim a; auto with arith.
 Qed.

 (* logarithm by default *)

 Lemma floor_log2 :
  forall n : nat,
  0 < n -> {l : nat | two_power l <= n /\ n < two_power (S l)}.
 (**************************************************************)
 Proof.
 refine (fun n _ => match log2 n _ with
                    | existS l b => exist _ l _
                    end).
 auto with arith.

(*
 Realizer [n:nat]<nat>let (l:nat;b:bool)=(log2 n) in  l .
  Program_all.
*)
  elim b; intro.
  rewrite a; split; auto with arith.
  elim b0; auto with arith.
 Qed.
End applications.