Require Import Platform.AutoSep Platform.Malloc Platform.Arrays8 Platform.MoreArrays.

Definition bmallocS : spec := SPEC("n") reserving 8
  PRE[V] [| V "n" >= $2 |] * mallocHeap 0
  POST[R] [| R <> 0 |] * [| freeable R (wordToNat (V "n")) |]
    * R =?>8 (wordToNat (V "n") * 4) * mallocHeap 0.

Definition bfreeS : spec := SPEC("p", "n") reserving 6
  PRE[V] [| V "p" <> 0 |] * [| freeable (V "p") (wordToNat (V "n")) |]
    * V "p" =?>8 (wordToNat (V "n") * 4) * mallocHeap 0
  POST[_] mallocHeap 0.

Definition containsS : spec := SPEC("haystack", "len", "needle") reserving 2
  PRE[V] V "haystack" =?>8 wordToNat (V "len")
  POST[_] V "haystack" =?>8 wordToNat (V "len").

Definition copyS : spec := SPEC("dst", "src", "srcLen") reserving 2
  Al dstLen,
  PRE[V] V "dst" =?>8 wordToNat dstLen * V "src" =?>8 wordToNat (V "srcLen") * [| V "srcLen" <= dstLen |]
  POST[_] V "dst" =?>8 wordToNat dstLen * V "src" =?>8 wordToNat (V "srcLen").

Inductive debufferize : Prop := Debufferize.
Hint Constructors debufferize.

Definition neg1 : W := wones _.

Definition m := bimport [[ "sys"!"abort" @ [abortS],
                           "malloc"!"malloc" @ [mallocS], "malloc"!"free" @ [freeS] ]]
  bmodule "buffers" {{
    bfunction "bmalloc"("n", "r") [bmallocS]
      "r" <-- Call "malloc"!"malloc"(0, "n")
      [PRE[_, R] Emp
       POST[R'] [| R' = R |] ];;
      Return "r"
    end with bfunction "bfree"("p", "n") [bfreeS]
      Assert [PRE[V] [| V "p" <> 0 |] * [| freeable (V "p") (wordToNat (V "n")) |]
        * V "p" =?> wordToNat (V "n") * mallocHeap 0
        POST[_] mallocHeap 0];;

      Call "malloc"!"free"(0, "p", "n")
      [PRE[_] Emp
       POST[_] Emp ];;
      Return 0
    end with bfunction "contains"("haystack", "len", "needle", "i", "tmp") [containsS]
      Note [debufferize];;

      Assert [Al bs, PRE[V] array8 bs (V "haystack") * [| length bs = wordToNat (V "len") |]
        POST[_] array8 bs (V "haystack")];;

      "i" <- 0;;

      [Al bs, PRE[V] array8 bs (V "haystack") * [| length bs = wordToNat (V "len") |]
        POST[_] array8 bs (V "haystack")]
      While ("i" < "len") {
        Assert [Al bs, PRE[V] array8 bs (V "haystack") * [| length bs = wordToNat (V "len") |]
          * [| (V "i" < natToW (length bs))%word |]
          POST[_] array8 bs (V "haystack")];;

        "tmp" <-*8 "haystack" + "i";;
        If ("tmp" = "needle") {
          Return "i"
        } else {
          "i" <- "i" + 1
        }
      };;

      Return neg1
    end with bfunction "copy"("dst", "src", "srcLen", "i", "tmp") [copyS]
      Note [debufferize];;

      Assert [Al src, Al dst,
        PRE[V] array8 dst (V "dst") * array8 src (V "src")
          * [| length src = wordToNat (V "srcLen") |] * [| (wordToNat (V "srcLen") <= length dst)%nat |]
          * [| goodSize (length dst) |]
        POST[_] Ex dst', array8 dst' (V "dst") * array8 src (V "src")
          * [| length dst' = length dst |] ];;

      "i" <- 0;;

      [Al src, Al dst,
        PRE[V] array8 dst (V "dst") * array8 src (V "src") * [| (wordToNat (V "srcLen") <= length dst)%nat |]
          * [| length src = wordToNat (V "srcLen") |]
          * [| goodSize (length dst) |]
        POST[_] Ex dst', array8 dst' (V "dst") * array8 src (V "src")
          * [| length dst' = length dst |] ]
      While ("i" < "srcLen") {
        Assert [Al src, Al dst,
          PRE[V] array8 dst (V "dst") * array8 src (V "src") * [| (wordToNat (V "srcLen") <= length dst)%nat |]
            * [| length src = wordToNat (V "srcLen") |] * [| goodSize (length dst) |]
            * [| (V "i" < natToW (length dst))%word |] * [| (V "i" < natToW (length src))%word |]
          POST[_] Ex dst', array8 dst' (V "dst") * array8 src (V "src")
            * [| length dst' = length dst |] ];;

        "tmp" <-*8 "src" + "i";;
        "dst" + "i" *<-8 "tmp";;
        "i" <- "i" + 1
      };;

      Return 0
    end
  }}.

Theorem dematerialize_buffer : forall p n, p =?>8 (n * 4) ===> p =?> n.
  unfold buffer; sepLemma; apply decomission_array8; auto.
Qed.

Ltac finish :=
  repeat match goal with
           | [ H : _ = _ |- _ ] => rewrite H
         end; try apply materialize_array8;
  try (etransitivity; [ apply himp_star_comm | apply himp_star_frame; reflexivity || apply dematerialize_buffer ]);
    try rewrite natToW_wordToNat; try rewrite length_upd; auto; try nomega.

Ltac t :=
  try match goal with
        | [ |- context[debufferize] ] => unfold buffer
      end; sep_auto; finish.

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

Theorem ok : moduleOk m.
  vcgen; abstract t.
Qed.


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

(** Constructions of ordered types, for use with the [FSet] functors
  for finite sets and the [FMap] functors for finite maps. *)

Require Import FSets.
Require Import Coqlib.
Require Import Maps.
(* Require Import Integers. *)

(** The ordered type of positive numbers *)

Module OrderedPositive <: OrderedType.

Definition t := positive.
Definition eq (x y: t) := x = y.
Definition lt := Plt.

Lemma eq_refl : forall x : t, eq x x.
Proof (@eq_refl t).
Lemma eq_sym : forall x y : t, eq x y -> eq y x.
Proof (@eq_sym t).
Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
Proof (@eq_trans t).
Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
Proof Plt_trans.
Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
Proof Plt_ne.
Lemma compare : forall x y : t, Compare lt eq x y.
Proof.
  intros. destruct (Pos.compare x y) as [] eqn:E.
  apply EQ. red. apply Pos.compare_eq_iff. assumption.
  apply LT. assumption.
  apply GT. apply Pos.compare_gt_iff. assumption.
Defined.

Definition eq_dec : forall x y, { eq x y } + { ~ eq x y } := peq.

End OrderedPositive.

(** The ordered type of integers *)

(* Module OrderedZ <: OrderedType. *)

(* Definition t := Z. *)
(* Definition eq (x y: t) := x = y. *)
(* Definition lt := Z.lt. *)

(* Lemma eq_refl : forall x : t, eq x x. *)
(* Proof (@eq_refl t). *)
(* Lemma eq_sym : forall x y : t, eq x y -> eq y x. *)
(* Proof (@eq_sym t). *)
(* Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. *)
(* Proof (@eq_trans t). *)
(* Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. *)
(* Proof Z.lt_trans. *)
(* Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. *)
(* Proof. unfold lt, eq, t; intros. omega. Qed. *)
(* Lemma compare : forall x y : t, Compare lt eq x y. *)
(* Proof. *)
(*   intros. destruct (Z.compare x y) as [] eqn:E. *)
(*   apply EQ. red. apply Z.compare_eq_iff. assumption. *)
(*   apply LT. assumption. *)
(*   apply GT. apply Z.compare_gt_iff. assumption. *)
(* Defined. *)

(* Definition eq_dec : forall x y, { eq x y } + { ~ eq x y } := zeq. *)

(* End OrderedZ. *)

(* (** The ordered type of machine integers *) *)

(* Module OrderedInt <: OrderedType. *)

(* Definition t := int. *)
(* Definition eq (x y: t) := x = y. *)
(* Definition lt (x y: t) := Int.unsigned x < Int.unsigned y. *)

(* Lemma eq_refl : forall x : t, eq x x. *)
(* Proof (@eq_refl t). *)
(* Lemma eq_sym : forall x y : t, eq x y -> eq y x. *)
(* Proof (@eq_sym t). *)
(* Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. *)
(* Proof (@eq_trans t). *)
(* Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. *)
(* Proof. *)
(*   unfold lt; intros. omega. *)
(* Qed. *)
(* Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. *)
(* Proof. *)
(*   unfold lt,eq; intros; red; intros. subst. omega. *)
(* Qed. *)
(* Lemma compare : forall x y : t, Compare lt eq x y. *)
(* Proof. *)
(*   intros. destruct (zlt (Int.unsigned x) (Int.unsigned y)). *)
(*   apply LT. auto. *)
(*   destruct (Int.eq_dec x y). *)
(*   apply EQ. auto. *)
(*   apply GT. *)
(*   assert (Int.unsigned x <> Int.unsigned y). *)
(*     red; intros. rewrite <- (Int.repr_unsigned x) in n. rewrite <- (Int.repr_unsigned y) in n. congruence. *)
(*   red. omega. *)
(* Defined. *)

(* Definition eq_dec : forall x y, { eq x y } + { ~ eq x y } := Int.eq_dec. *)

(* End OrderedInt. *)

(* (** Indexed types (those that inject into [positive]) are ordered. *) *)

(* Module OrderedIndexed(A: INDEXED_TYPE) <: OrderedType. *)

(* Definition t := A.t. *)
(* Definition eq (x y: t) := x = y. *)
(* Definition lt (x y: t) := Plt (A.index x) (A.index y). *)

(* Lemma eq_refl : forall x : t, eq x x. *)
(* Proof (@eq_refl t). *)
(* Lemma eq_sym : forall x y : t, eq x y -> eq y x. *)
(* Proof (@eq_sym t). *)
(* Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. *)
(* Proof (@eq_trans t). *)

(* Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. *)
(* Proof. *)
(*   unfold lt; intros. eapply Plt_trans; eauto. *)
(* Qed. *)

(* Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. *)
(* Proof. *)
(*   unfold lt; unfold eq; intros. *)
(*   red; intro. subst y. apply Plt_strict with (A.index x). auto. *)
(* Qed. *)

(* Lemma compare : forall x y : t, Compare lt eq x y. *)
(* Proof. *)
(*   intros. case (OrderedPositive.compare (A.index x) (A.index y)); intro. *)
(*   apply LT. exact l. *)
(*   apply EQ. red; red in e. apply A.index_inj; auto. *)
(*   apply GT. exact l. *)
(* Defined. *)

(* Lemma eq_dec : forall x y, { eq x y } + { ~ eq x y }. *)
(* Proof. *)
(*   intros. case (peq (A.index x) (A.index y)); intros. *)
(*   left. apply A.index_inj; auto. *)
(*   right; red; unfold eq; intros; subst. congruence. *)
(* Defined. *)

(* End OrderedIndexed. *)

(* (** The product of two ordered types is ordered. *) *)

(* Module OrderedPair (A B: OrderedType) <: OrderedType. *)

(* Definition t := (A.t * B.t)%type. *)

(* Definition eq (x y: t) := *)
(*   A.eq (fst x) (fst y) /\ B.eq (snd x) (snd y). *)

(* Lemma eq_refl : forall x : t, eq x x. *)
(* Proof. *)
(*   intros; split; auto. *)
(* Qed. *)

(* Lemma eq_sym : forall x y : t, eq x y -> eq y x. *)
(* Proof. *)
(*   unfold eq; intros. intuition auto. *)
(* Qed. *)

(* Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. *)
(* Proof. *)
(*   unfold eq; intros. intuition eauto. *)
(* Qed. *)

(* Definition lt (x y: t) := *)
(*   A.lt (fst x) (fst y) \/ *)
(*   (A.eq (fst x) (fst y) /\ B.lt (snd x) (snd y)). *)

(* Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. *)
(* Proof. *)
(*   unfold lt; intros. *)
(*   elim H; elim H0; intros. *)

(*   left. apply A.lt_trans with (fst y); auto. *)

(*   left.  elim H1; intros. *)
(*   case (A.compare (fst x) (fst z)); intro. *)
(*   assumption. *)
(*   generalize (A.lt_not_eq H2); intro. elim H5. *)
(*   apply A.eq_trans with (fst z). auto. auto. *)
(*   generalize (@A.lt_not_eq (fst z) (fst y)); intro. *)
(*   elim H5. apply A.lt_trans with (fst x); auto. *)
(*   apply A.eq_sym; auto. *)

(*   left. elim H2; intros. *)
(*   case (A.compare (fst x) (fst z)); intro. *)
(*   assumption. *)
(*   generalize (A.lt_not_eq H1); intro. elim H5. *)
(*   apply A.eq_trans with (fst x). *)
(*   apply A.eq_sym. auto. auto. *)
(*   generalize (@A.lt_not_eq (fst y) (fst x)); intro. *)
(*   elim H5. apply A.lt_trans with (fst z); auto. *)
(*   apply A.eq_sym; auto. *)

(*   right. elim H1; elim H2; intros. *)
(*   split. apply A.eq_trans with (fst y); auto. *)
(*   apply B.lt_trans with (snd y); auto. *)
(* Qed. *)

(* Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. *)
(* Proof. *)
(*   unfold lt, eq, not; intros. *)
(*   elim H0; intros. *)
(*   elim H; intro. *)
(*   apply (@A.lt_not_eq _ _ H3 H1). *)
(*   elim H3; intros. *)
(*   apply (@B.lt_not_eq _ _ H5 H2). *)
(* Qed. *)

(* Lemma compare : forall x y : t, Compare lt eq x y. *)
(* Proof. *)
(*   intros. *)
(*   case (A.compare (fst x) (fst y)); intro. *)
(*   apply LT. red. left. auto. *)
(*   case (B.compare (snd x) (snd y)); intro. *)
(*   apply LT. red. right. tauto. *)
(*   apply EQ. red. tauto. *)
(*   apply GT. red. right. split. apply A.eq_sym. auto. auto. *)
(*   apply GT. red. left. auto. *)
(* Defined. *)

(* Lemma eq_dec : forall x y, { eq x y } + { ~ eq x y }. *)
(* Proof. *)
(*   unfold eq; intros. *)
(*   case (A.eq_dec (fst x) (fst y)); intros. *)
(*   case (B.eq_dec (snd x) (snd y)); intros. *)
(*   left; auto. *)
(*   right; intuition. *)
(*   right; intuition. *)
(* Defined. *)

(* End OrderedPair. *)


From Undecidability.L Require Import Tactics.LTactics Prelim.MoreList Prelim.MoreBase.
From Complexity.Complexity Require Import NP Definitions Monotonic.
From Complexity.NP Require Import L.GenNP.

(** * From L to TMs *)

(** Start: *)
(** * This start might be bad, as we need to check the bound explicitly, e.g. count the beta-steps during the simulation. *)
(** * But we can choose the bound large enough such that the term we simulate halts in the bound or always diverges *)
(** * We might want to simulate some L term that always halts *)
(** * But that means we need to distinguish true/false in the representation. *)

(** * Eventuell moechten wir nicht mit einem "einfachen" problem starten, sondern erst eienn lambda-trm scheiben, der decider für eine lang genuge zeit simulirt und dann hält oder divergiert, je nachdem ob der Decider wahr oder falsch sagt *)
(** * Divergenz ist ein schlechter Problem, wenn man von divergens reduziert, da man häufig nur obere schranken für die Laufzeit der Simulatoren hat.

Da der simulierte Term evtl aber mit groesserer Schranke haelt muesste man dann schritte mitzählen. *)

(* Weitere Idee: Prädikat nutzen, um Probleminstanzen weiter einzuschränken? *)

From Undecidability.TM Require Import TM CodeTM.
From Undecidability Require Import LFinType.

From Complexity Require Import NP L_to_LM LM_to_mTM mTM_to_singleTapeTM TMGenNP_fixed_mTM Subtypes.

Import LNat.
Lemma GenNP_to_TMGenNP:
  GenNP (list bool) ⪯p TMGenNP_fixed (projT1 (M_multi2mono.M__mono (projT1 M.M))).
Proof.
  eapply reducesPolyMO_transitive. now apply GenNP_to_LMGenNP.
  eapply reducesPolyMO_transitive. now apply LMGenNP_to_TMGenNP_mTM.
  now apply TMGenNP_mTM_to_TMGenNP_singleTM.
Qed.

(*
Print Assumptions GenNP_to_TMGenNP.
*)
(** Not Complete: nice form of Time bound *)
(*From Undecidability.L.AbstractMachines.TM_LHeapInterpreter  Require TM.LMBounds. *)

(** Approach: simulate step-indexed L interpreter inside TM *)
(** Problems: Well-formedness of certificate-input? *)

(** Maybe intermediate problem in terms of Heap-Machine? *)


From iris.proofmode Require Import tactics.
From iris.algebra Require Import gmap auth agree gset coPset.
From Perennial.base_logic.lib Require Import wsat.
From Perennial.program_logic Require Export weakestpre.
From Perennial.program_logic Require Export crash_lang dist_lang crash_weakestpre recovery_weakestpre.
Import uPred.

Set Default Proof Using "Type".

(*** Distributed WP ***)

Section wpd.
Context `{HI: !irisGS Λ Σ}.

Definition wpd CS (E: coPset) (ers: list node_init_cfg) :=
 ([∗ list] i↦σ ∈ ers, ∀ `(Hc: !crashGS Σ),
   |={⊤}=> ∃ (stateI : state Λ → nat → iProp Σ) (* for the initial generation *) Φ Φrx Φinv,
   let HG := GenerationGS Λ Σ Hc stateI in
   stateI σ.(init_local_state) 0 ∗
   wpr CS NotStuck HG E σ.(init_thread) σ.(init_restart) Φ Φinv Φrx)%I.

Lemma wpd_compose CS E ers1 ers2 :
  wpd CS E ers1 -∗
  wpd CS E ers2 -∗
  wpd CS E (ers1 ++ ers2).
Proof. rewrite /wpd big_sepL_app. iIntros "$ $". Qed.

End wpd.


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

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

Require Import Time.
Require Import View.
Require Import BoolMap.
Require Import Promises.
Require Import Cell.
Require Import Memory.
Require Import Global.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.

Require Import Progress.
Require Import ReorderInternal.

Require Import SimLocal.
Require Import SimMemory.
Require Import SimGlobal.
Require Import SimThread.
Require Import Compatibility.

Require Import ReorderStep.
Require Import ReorderLoad.
Require Import ReorderFence.
Require Import ReorderAbort.
Require Import ReorderChoose.

Require Import ITreeLang.
Require Import ITreeLib.

Set Implicit Arguments.

Variant reorder: forall R0 R1 (i1: MemE.t R0) (i2: MemE.t R1), Prop :=
| reorder_intro_load
    R1 l1 o1 (i2: MemE.t R1)
    (REORDER: reorder_load l1 o1 i2):
    reorder (MemE.read l1 o1) i2
| reorder_intro_fence
    R1 or1 ow1 (i2: MemE.t R1)
    (REORDER: reorder_fence or1 ow1 i2):
    reorder (MemE.fence or1 ow1) i2
| reorder_intro_abort
    R1 (i2: MemE.t R1)
    (REORDER: reorder_abort i2):
    reorder MemE.abort i2
| reorder_intro_choose
    R1 (i2: MemE.t R1)
    (REORDER: reorder_choose i2):
    reorder MemE.choose i2
.

Lemma reorder_sim_itree R0 R1
      (i1: MemE.t R0) (i2: MemE.t R1) (REORDER: reorder i1 i2):
  sim_itree eq
            (r2 <- ITree.trigger i2;; r1 <- ITree.trigger i1;; Ret (r1, r2))
            (r1 <- ITree.trigger i1;; r2 <- ITree.trigger i2;; Ret (r1, r2)).
Proof.
  replace (r2 <- ITree.trigger i2;; r1 <- ITree.trigger i1;; Ret (r1, r2)) with
      (Vis i2 (fun r2 => Vis i1 (fun r1 => Ret (r1, r2)))).
  2:{ unfold ITree.trigger. grind. repeat f_equal. extensionality r2. grind.
      repeat f_equal. extensionality r1. grind. }
  replace (r1 <- ITree.trigger i1;; r2 <- ITree.trigger i2;; Ret (r1, r2)) with
      (Vis i1 (fun r1 => Vis i2 (fun r2 => Ret (r1, r2)))).
  2:{ unfold ITree.trigger. grind. repeat f_equal. extensionality r2. grind.
      repeat f_equal. extensionality r1. grind. }
  pcofix CIH. ii. subst. pfold. ii. splits; ii.
  { inv TERMINAL_TGT. eapply f_equal with (f:=observe) in H; ss. }
  { right. esplits; eauto. inv LOCAL. congr. }
  inv STEP_TGT; [|destruct REORDER; ss; dependent destruction STATE; inv LOCAL0]; ss; clarify.
  - (* internal *)
    right.
    exploit sim_local_internal; eauto. i. des.
    esplits; try apply GL2; eauto.
    inv LOCAL0; ss.
  - (* load *)
    right.
    exploit sim_local_read; eauto; try refl. i. des.
    esplits; try apply GLOBAL; eauto; ss.
    left. eapply paco9_mon; [apply sim_load_sim_thread|]; ss.
    econs; eauto.
    eapply Local.read_step_future; eauto.
  - (* racy read *)
    right.
    exploit sim_local_racy_read; eauto; try refl. i. des.
    esplits; try apply GLOBAL; eauto; ss.
    left. eapply paco9_mon; [apply sim_load_sim_thread|]; ss.
    econs 2; eauto.
  - (* fence *)
    right.
    exploit sim_local_fence; eauto; try refl. i. des.
    exploit Local.fence_step_future; try exact LOCAL1; eauto. i. des.
    assert (GLOBAL3: sim_global gl1_src gl3_tgt).
    { etrans; [|eauto]. inv STEP_SRC. inv GLOBAL2.
      econs; ss; try refl.
      apply TViewFacts.write_fence_sc_incr.
    }
    esplits.
    + ss.
    + refl.
    + econs 1.
    + ss.
    + ss.
    + left. eapply paco9_mon; [apply sim_fence_sim_thread|]; ss.
      econs; eauto.
  - (* abort *)
    left.
    eapply sim_abort_steps_failure.
    econs; eauto.
  - (* choose *)
    right.
    esplits; eauto; ss.
    left. eapply paco9_mon; [apply sim_choose_sim_thread|]; ss.
Qed.


Require Import FcEtt.sigs.

Require Import FcEtt.imports.
Require Import FcEtt.tactics.

Require Import FcEtt.ett_ott.
Require Import FcEtt.ett_inf.
Require Import FcEtt.ett_inf_cs.
Require Import FcEtt.ett_ind.

Require Import FcEtt.ett_par.
Require Import FcEtt.ext_invert.
Require Import FcEtt.ext_red.
Require Import FcEtt.ext_red_one.
Require Import FcEtt.erase_syntax.

Require Import FcEtt.fc_invert FcEtt.fc_unique.

Module fc_preservation (wf : fc_wf_sig) (weak : fc_weak_sig) (subst : fc_subst_sig)
        (e_subst : ext_subst_sig).

Import subst weak wf.

Module e_invert := ext_invert e_subst.
Import e_invert.

Module red := ext_red e_invert.
Import red.

Module red_one := ext_red_one e_invert.
Import red_one.

Module invert := fc_invert wf weak subst.
Module unique := fc_unique wf subst.
Import invert unique.

Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.

(* This version is just for "head reduction."
 *)

Lemma open_a_Conv : forall a b g,
    open_tm_wrt_tm (a_Conv a g) b =
    a_Conv (open_tm_wrt_tm a b) (open_co_wrt_tm g b).
intros.
unfold open_tm_wrt_tm. simpl. auto.
Qed.

Lemma open_a_Conv_co : forall a b g,
    open_tm_wrt_co (a_Conv a g) b =
    a_Conv (open_tm_wrt_co a b) (open_co_wrt_co g b).
intros.
unfold open_tm_wrt_co. simpl. auto.
Qed.

(* Helper tactic for below. Solves lc_tm goals using hypotheses from
   the annotated language. Perhaps it is useful elsewhere? *)
Ltac lc_erase_hyp :=
  match goal with
  | H : AnnTyping ?G ?a ?A0 |- lc_tm (erase_tm ?a) => eapply lc_erase; apply (AnnTyping_lc H)
  | H : AnnTyping ?G ?a ?A0 |- lc_tm ?a => apply (AnnTyping_lc1 H)
  | H : lc_tm ?a |- lc_tm (erase ?a) => eapply lc_erase; eauto
  | H : lc_tm (a_Abs ?r ?a ?b) |- lc_tm ?c => apply lc_erase in H; simpl in H; auto
  | H : lc_tm (a_CAbs ?a ?b) |- lc_tm ?c => apply lc_erase in H; simpl in H; auto
  end.

Lemma binds_toplevel: forall F a A,
  binds F (Ax a A) an_toplevel ->
  binds F (Ax (erase a) (erase A)) toplevel.
Proof.
  intros.
  unfold toplevel. unfold erase_sig.
  eapply binds_map with (f:= erase_csort) in H.
  auto.
Qed.

Ltac do_rho :=
  match goal with
    H : ∀ x : atom, x `notin` ?L → RhoCheck Irrel x (erase_tm (open_tm_wrt_tm ?b (a_Var_f x))) |-
                    ?x `notin` fv_tm_tm_tm (open_tm_wrt_tm (erase ?b) (a_Var_f ?x)) =>
    let h := fresh in
    let F := fresh in
    assert (F : x `notin` L); auto;
    move: (H x F) => h; inversion h; subst;
    replace (a_Var_f x) with (erase (a_Var_f x)); auto;
    rewrite open_tm_erase_tm; auto
  end.

(* A specialized version of eauto that only uses the most common
   lc lemmas to cut down the search space. *)
Ltac eauto_lc := simpl; eauto using AnnTyping_lc1, Value_lc,
                        AnnDefEq_lc3, AnnPropWff_lc.

(* We need to know that the term type checks.  But if it does, our annotated
   operational semantics corresponds with reduction_in_one. *)
Lemma head_reduction_in_one : forall G a b,
    head_reduction G a b -> forall A,  AnnTyping G a A ->
    reduction_in_one (erase a) (erase b) \/ erase a = erase b.
Proof.
  move: lc_erase => [lc_er_tm _] G a b H.
  induction H; intros AA TT ; inversion TT; try (simpl; eauto).
  - destruct rho.
    destruct (IHhead_reduction _ H6); subst; simpl.
    left. eauto. simpl in H8. rewrite H8. eauto.
    destruct (IHhead_reduction _ H6); subst; simpl.
    left. eauto. simpl in H8. rewrite H8. eauto.
  - subst. destruct rho; left; simpl_erase.
    ++ eapply E_AppAbs; eauto using lc_er_tm.
       eapply Value_lc in H0. lc_erase_hyp.
    ++ inversion H6; clear H6; subst.
       pose EB := erase w.
       pick fresh x.
       rewrite (tm_subst_tm_tm_intro x); auto using fv_tm_erase_tm.
       rewrite tm_subst_tm_tm_fresh_eq.
       rewrite -(tm_subst_tm_tm_fresh_eq (open_tm_wrt_tm (erase w) (a_Var_f x)) a_Bullet x).
       rewrite -tm_subst_tm_tm_intro; eauto.
       econstructor. auto.
       eapply Value_erase in H0. auto.
       do_rho.
       do_rho.
  - subst.
    destruct (IHhead_reduction _ H4); simpl.
    eauto.
    simpl in H1. rewrite H1.
    eauto.
  - subst. left. autorewcs.
    erewrite <- open_co_erase_tm2.
    econstructor. apply lc_er_tm in H0. eauto.
  - subst.
    pick fresh x.
    edestruct (H1 x); eauto.
    left. apply E_AbsTerm_exists with (x:=x).
    eauto using fv_tm_erase_tm.
    rewrite <- open_tm_erase_tm in H2.
    rewrite <- open_tm_erase_tm in H2.
    simpl in H2. eauto.
    right. f_equal.
    move: (H9 x ltac:(auto)) => h0. inversion h0. subst.
    rewrite <- open_tm_erase_tm in H2.
    rewrite <- open_tm_erase_tm in H2.
    simpl in H2.
    apply open_tm_wrt_tm_inj in H2.
    auto.
    eauto using fv_tm_erase_tm.
    eauto using fv_tm_erase_tm.
  - left.
    assert (Ax a A = Ax a0 AA).
    { eapply binds_unique; eauto. apply uniq_an_toplevel. } inversion H6. subst.
    apply binds_toplevel in H.
    eauto.
  - subst. destruct rho.
    simpl. eauto.
    simpl. eauto.
Qed.

(* We need to know that the term type checks.  But if it does, our annotated
   operational semantics corresponds with parallel reduction. *)

Lemma head_reduction_erased : forall G a b, head_reduction G a b ->
    forall A, AnnTyping G a A ->  Par G (dom G) (erase a) (erase b).
Proof.
  intros G a b H.
  induction H; intros AA TT ; inversion TT; try (simpl; econstructor; eauto).
  + destruct rho; simpl. econstructor; eauto. econstructor.
    eapply lc_erase. eapply AnnTyping_lc with (A := A). eauto.
    econstructor; eauto.
  + destruct rho; simpl_erase.
    econstructor.
    econstructor. apply Value_lc in H0. lc_erase_hyp.
    econstructor. apply Value_lc in H0. lc_erase_hyp.
    match goal with
      H :  AnnTyping ?G (a_Abs Irrel ?A ?b) (a_Pi Irrel ?A0 ?B) |- _ => inversion H; clear H end. subst.
    pose EB := (erase w).
    pick fresh x.
    rewrite (tm_subst_tm_tm_intro x); auto using fv_tm_erase_tm.
    rewrite tm_subst_tm_tm_fresh_eq.
    rewrite -(tm_subst_tm_tm_fresh_eq (open_tm_wrt_tm (erase w) (a_Var_f x)) a_Bullet x).
    rewrite -tm_subst_tm_tm_intro; eauto.
    econstructor. econstructor. apply Value_lc in H0.
    match goal with H : lc_tm (a_Abs Irrel ?A0 ?b) |-
                    lc_tm (a_UAbs Irrel (erase ?b)) => eapply lc_erase in H; simpl in H; auto end.
    do_rho.
    do_rho.
  + subst. simpl.
    autorewcs. rewrite -(open_co_erase_tm2 _ _ g_Triv).
    econstructor. econstructor. lc_erase_hyp.
  + intros.
    assert (x `notin` L \u L0). eapply H10.
    replace (a_Var_f x) with (erase (a_Var_f x)); auto.
    rewrite open_tm_erase_tm.
    rewrite open_tm_erase_tm.
    eapply context_Par_irrelevance; eauto.
  + unfold toplevel. unfold erase_sig.
    apply binds_map with (f := erase_csort) in H.
    simpl in H.
    eauto.
  + simpl. eauto.
  + match goal with
      H : AnnTyping ?G (a_Conv ?v ?g1) ?A |- lc_tm (erase_tm ?v) =>
      inversion H end.
    lc_erase_hyp.
  + destruct rho; subst; simpl; eauto using lc_erase.
    econstructor. eapply AnnTyping_lc1 in TT. eapply lc_tm_erase in TT. eauto.
    econstructor. eapply AnnTyping_lc1 in TT. eapply lc_tm_erase in TT. eauto.
  + eapply AnnTyping_lc1 in TT. eapply lc_tm_erase in TT. eauto.
Qed.

Lemma preservation : forall G a A, AnnTyping G a A -> forall a', head_reduction G a a' -> AnnTyping G a' A.
Proof.
  intros G a A H. induction H.
  - intros. inversion H0.
  - intros. inversion H1.
  - intros. inversion H2; subst.
  - intros. inversion H3. subst.
    pick fresh x and apply An_Abs; eauto 3.
    have RC: RhoCheck Irrel x (erase_tm (open_tm_wrt_tm a (a_Var_f x))); eauto.
    inversion RC. subst.
    have HR: head_reduction ([(x, Tm A)] ++ G) (open_tm_wrt_tm a (a_Var_f x))
                            (open_tm_wrt_tm b' (a_Var_f x)); eauto.
    have Ta: AnnTyping ([(x, Tm A)] ++ G) (open_tm_wrt_tm b' (a_Var_f x))
                       (open_tm_wrt_tm B (a_Var_f x)); eauto.
    constructor.
    eapply Par_fv_preservation; eauto.
    eapply head_reduction_erased; eauto.
  - (* application case *)
    intros. inversion H1; subst.
    + eauto.
    + inversion H. subst.
      pick fresh x.
      rewrite (tm_subst_tm_tm_intro x); auto.
      rewrite (tm_subst_tm_tm_intro x B); auto.
      eapply AnnTyping_tm_subst; eauto.
    + (* Push case *)
      inversion H. subst. resolve_unique_subst.
      move: (AnnDefEq_regularity H7)  => [C1 [C2 [g' hyps]]]. split_hyp.
      invert_syntactic_equality.
      inversion H2. inversion H6. subst.
      eapply An_Conv; eauto.
      eapply An_PiSnd; eauto.
      eapply An_EraseEq; eauto.
      eapply AnnTyping_tm_subst_nondep; eauto.
  - intros. inversion H2; subst.
    + eauto.
    + inversion H. subst.
      econstructor; eauto 2.
      eapply An_Trans with (a1 := A); eauto 2 using AnnTyping_regularity.
      eapply An_Refl; eauto with ctx_wff.
  - intros. inversion H2.
  - intros. inversion H2.
  - intros. inversion H1; subst.
    + eauto.
    + inversion H; subst.
      pick fresh c.
      rewrite (co_subst_co_tm_intro c); auto.
      rewrite (co_subst_co_tm_intro c B); auto.
      eapply AnnTyping_co_subst; eauto.
    + (* CPush case *)
      inversion H. subst. resolve_unique_subst.
      move: (AnnDefEq_regularity H5)  => [C1 [C2 [g' hyps]]]. split_hyp.
      invert_syntactic_equality.
      inversion H2. inversion H7. subst. destruct phi1.
      eapply An_Conv; eauto.
      eapply AnnTyping_co_subst_nondep; eauto.
  - move=> a' hr.
    inversion hr.
  - move=> a' hr.
    inversion hr. subst.

    assert (Ax a A = Ax a' A0).
    { eapply binds_unique; eauto. apply uniq_an_toplevel. }
    inversion H2. subst. clear H2. clear H0.
    apply an_toplevel_closed in H4.
    eapply AnnTyping_weakening with (F:=nil)(G:=nil)(E:=G) in H4; eauto.
    simpl in H4.
    rewrite app_nil_r in H4.
    auto.
    rewrite app_nil_r. simpl. auto.
Qed. (* preservation *)

End fc_preservation.


Require Import CompCert.Events.
Require Import CompCert.Smallstep.
Require Import CompCert.Behaviors.
Require Import Common.Definitions.
Require Import Common.Util.
Require Import Common.Linking.
Require Import Common.Memory.
Require Import Common.Traces.
Require Import Common.CompCertExtensions.
Require Import Intermediate.Machine.
Require Import Intermediate.GlobalEnv.
Require Import Lib.Extra.
Require Import Lib.Monads.
Require Import Intermediate.CS.
Import CS.

From mathcomp Require ssreflect ssrfun ssrbool eqtype.

Set Bullet Behavior "Strict Subproofs".

Module CS.

Import Intermediate.

(* A similar result is used above. Here is a weaker formulation. *)
Lemma initial_state_stack_state0 p s :
  initial_state p s ->
  stack_state_of s = Traces.stack_state0.
Proof.
  intros Hini.
  unfold initial_state, initial_machine_state in Hini.
  destruct (prog_main p) as [mainP |]; simpl in Hini.
  - destruct (prepare_procedures p (prepare_initial_memory p))
      as [[mem dummy] entrypoints].
    destruct (EntryPoint.get Component.main mainP entrypoints).
    + subst. reflexivity.
    + subst. reflexivity.
  - subst. reflexivity.
Qed.

Lemma comes_from_initial_state_mergeable_sym :
  forall s iface1 iface2,
    Linking.mergeable_interfaces iface1 iface2 ->
    comes_from_initial_state s (unionm iface1 iface2) ->
    comes_from_initial_state s (unionm iface2 iface1).
Proof.
  intros s iface1 iface2 [[_ Hdisjoint] _] Hfrom_initial.
  rewrite <- (unionmC Hdisjoint).
  exact Hfrom_initial.
Qed.

(* RB: NOTE: Consider possible alternatives on [CS.comes_from_initial_state]
   complemented instead by, say, [PS.step] based on what we usually have in
   the context, making for more direct routes. *)
Lemma comes_from_initial_state_step_trans p s t s' :
  CS.comes_from_initial_state s (prog_interface p) ->
  CS.step (prepare_global_env p) s t s' ->
  CS.comes_from_initial_state s' (prog_interface p).
Admitted. (* Grade 2. *)

(* RB: TODO: These domain lemmas should now be renamed to reflect their
   operation on linked programs. *)
Section ProgramLink.
  Variables p c : program.
  Hypothesis Hwfp  : well_formed_program p.
  Hypothesis Hwfc  : well_formed_program c.
  Hypothesis Hmergeable_ifaces :
    mergeable_interfaces (prog_interface p) (prog_interface c).
  Hypothesis Hprog_is_closed  : closed_program (program_link p c).

  Import ssreflect.

  (* RB: NOTE: Check with existing results (though currently unused). *)
  Lemma star_stack_cons_domm {s frame gps mem regs pc t} :
    initial_state (program_link p c) s ->
    Star (sem (program_link p c)) s t (frame :: gps, mem, regs, pc) ->
    Pointer.component frame \in domm (prog_interface p) \/
    Pointer.component frame \in domm (prog_interface c).
  Proof.
    intros Hini Hstar.
    assert (H : Pointer.component frame \in domm (prog_interface (program_link p c))).
    { eapply CS.comes_from_initial_state_stack_cons_domm.
      destruct (cprog_main_existence Hprog_is_closed) as [i [_ [? _]]].
      exists (program_link p c), i, s, t.
      split; first (destruct Hmergeable_ifaces; now apply linking_well_formedness).
      repeat split; eauto. }
    move: H. simpl. rewrite domm_union. now apply /fsetUP.
  Qed.
End ProgramLink.

End CS.


Require Import coqutil.Macros.subst coqutil.Macros.unique coqutil.Map.Interface coqutil.Word.Properties.
Require Import coqutil.Word.Bitwidth.
Require bedrock2.WeakestPrecondition.

Require Import Coq.Classes.Morphisms.

Section WeakestPrecondition.
  Context {width} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: Semantics.ExtSpec}.

  Ltac ind_on X :=
    intros;
    (* Note: Comment below dates from when we were using a parameter record p *)
    (* Note: "before p" means actually "after p" when reading from top to bottom, because,
       as the manual points out, "before" and "after" are with respect to the direction of
       the move, and we're moving hypotheses upwards here.
       We need to make sure not to revert/clear p, because the other lemmas depend on it.
       If we still reverted/cleared p, we'd get errors like
       "Error: Proper_load depends on the variable p which is not declared in the context."
       when trying to use Proper_load, or, due to COQBUG https://github.com/coq/coq/issues/11487,
       we'd get a typechecking failure at Qed time. *)
    repeat match goal with x : ?T |- _ => first
       [ constr_eq T X; move x before ext_spec
       | constr_eq T X; move x before env
       | constr_eq T X; move x before locals
       | constr_eq T X; move x at top
       | revert x ] end;
    match goal with x : X |- _ => induction x end;
    intros.

  Local Hint Mode word.word - : typeclass_instances.

  (* we prove weakening lemmas for all WP definitions in a syntax-directed fashion,
   * moving from postcondition towards precondition one logical connective at a time. *)
  Global Instance Proper_literal : Proper (pointwise_relation _ ((pointwise_relation _ Basics.impl) ==> Basics.impl)) WeakestPrecondition.literal.
  Proof using. clear. cbv [WeakestPrecondition.literal]; cbv [Proper respectful pointwise_relation Basics.impl dlet.dlet]. eauto. Qed.

  Global Instance Proper_get : Proper (pointwise_relation _ (pointwise_relation _ ((pointwise_relation _ Basics.impl) ==> Basics.impl))) WeakestPrecondition.get.
  Proof using. clear. cbv [WeakestPrecondition.get]; cbv [Proper respectful pointwise_relation Basics.impl]; intros * ? (?&?&?); eauto. Qed.

  Global Instance Proper_load : Proper (pointwise_relation _ (pointwise_relation _ (pointwise_relation _ ((pointwise_relation _ Basics.impl) ==> Basics.impl)))) WeakestPrecondition.load.
  Proof using. clear. cbv [WeakestPrecondition.load]; cbv [Proper respectful pointwise_relation Basics.impl]; intros * ? (?&?&?); eauto. Qed.

  Global Instance Proper_store : Proper (pointwise_relation _ (pointwise_relation _ (pointwise_relation _ (pointwise_relation _ ((pointwise_relation _ Basics.impl) ==> Basics.impl))))) WeakestPrecondition.store.
  Proof using. clear. cbv [WeakestPrecondition.store]; cbv [Proper respectful pointwise_relation Basics.impl]; intros * ? (?&?&?); eauto. Qed.

  Global Instance Proper_expr : Proper (pointwise_relation _ (pointwise_relation _ (pointwise_relation _ ((pointwise_relation _ Basics.impl) ==> Basics.impl)))) WeakestPrecondition.expr.
  Proof using.
    clear.
    cbv [Proper respectful pointwise_relation Basics.impl]; ind_on Syntax.expr.expr;
      cbn in *; intuition (try typeclasses eauto with core).
    { eapply Proper_literal; eauto. }
    { eapply Proper_get; eauto. }
    { eapply IHa1; eauto; intuition idtac. eapply Proper_load; eauto using Proper_load. }
    { eapply IHa1; eauto; intuition idtac. eapply Proper_load; eauto using Proper_load. }
    { eapply IHa1_1; eauto; intuition idtac.
      Tactics.destruct_one_match; eauto using Proper_load. }
  Qed.

  Global Instance Proper_list_map {A B} :
    Proper ((pointwise_relation _ (pointwise_relation _ Basics.impl ==> Basics.impl)) ==> pointwise_relation _ (pointwise_relation _ Basics.impl ==> Basics.impl)) (WeakestPrecondition.list_map (A:=A) (B:=B)).
  Proof using.
    clear.
    cbv [Proper respectful pointwise_relation Basics.impl]; ind_on (list A);
      cbn in *; intuition (try typeclasses eauto with core).
  Qed.

  Context {word_ok : word.ok word} {mem_ok : map.ok mem}.
  Context {locals_ok : map.ok locals}.
  Context {env_ok : map.ok env}.
  Context {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.

  Global Instance Proper_cmd :
    Proper (
     (pointwise_relation _ (pointwise_relation _ (pointwise_relation _ (pointwise_relation _ (pointwise_relation _ ((pointwise_relation _ (pointwise_relation _ Basics.impl))) ==> Basics.impl)))) ==>
     pointwise_relation _ (
     pointwise_relation _ (
     pointwise_relation _ (
     pointwise_relation _ (
     (pointwise_relation _ (pointwise_relation _ (pointwise_relation _ Basics.impl))) ==>
     Basics.impl)))))) WeakestPrecondition.cmd.
  Proof.
    cbv [Proper respectful pointwise_relation Basics.flip Basics.impl]; ind_on Syntax.cmd.cmd;
      cbn in *; cbv [dlet.dlet] in *; intuition (try typeclasses eauto with core).
    { destruct H1 as (?&?&?). eexists. split.
      1: eapply Proper_expr.
      1: cbv [pointwise_relation Basics.impl]; intuition eauto 2.
      all: eauto. }
    { destruct H1 as (?&?&?). eexists. split.
      { eapply Proper_expr.
        { cbv [pointwise_relation Basics.impl]; intuition eauto 2. }
        { eauto. } }
      { destruct H2 as (?&?&?). eexists. split.
        { eapply Proper_expr.
          { cbv [pointwise_relation Basics.impl]; intuition eauto 2. }
          { eauto. } }
        { eapply Proper_store; eauto; cbv [pointwise_relation Basics.impl]; eauto. } } }
    { eapply H1; [ | | eapply H3; eassumption ].
      2 : intros ? ? ? (?&?&?&?&?). all : eauto 7. }
    { destruct H1 as (?&?&?). eexists. split.
      { eapply Proper_expr.
        { cbv [pointwise_relation Basics.impl]; intuition eauto 2. }
        { eauto. } }
      { intuition eauto 6. } }
    { destruct H1 as (?&?&?&?&?&HH).
      eassumption || eexists.
      eassumption || eexists.
      eassumption || eexists.
      eassumption || eexists. { eassumption || eexists. }
      eassumption || eexists. { eassumption || eexists. }
      intros X Y Z T W.
      specialize (HH X Y Z T W).
      destruct HH as (?&?&?). eexists. split.
      1: eapply Proper_expr.
      1: cbv [pointwise_relation Basics.impl].
      all:intuition eauto 2.
      - eapply H2; eauto; cbn; intros.
        match goal with H:_ |- _ => destruct H as (?&?&?); solve[eauto] end.
      - intuition eauto. }
    { destruct H1 as (?&?&?). eexists. split.
      { eapply Proper_list_map; eauto; try exact H4; cbv [respectful pointwise_relation Basics.impl]; intuition eauto 2.
        eapply Proper_expr; eauto. }
      { eapply H. 2: eauto.
        (* COQBUG (performance), measured in Coq 8.9:
           "firstorder eauto" works, but takes ~100s and increases memory usage by 1.8GB.
           On the other hand, the line below takes just 5ms *)
        cbv beta; intros ? ? ? (?&?&?); eauto. } }
    { destruct H1 as (?&?&?). eexists. split.
      { eapply Proper_list_map; eauto; try exact H4; cbv [respectful pointwise_relation Basics.impl].
        { eapply Proper_expr; eauto. }
        { eauto. } }
      { destruct H2 as (mKeep & mGive & ? & ?).
        exists mKeep. exists mGive.
        split; [assumption|].
        eapply Semantics.ext_spec.weaken; [|solve[eassumption]].
        intros ? ? (?&?&?); eauto 10. } }
  Qed.

  Global Instance Proper_func :
    Proper (
     (pointwise_relation _ (pointwise_relation _ (pointwise_relation _ (pointwise_relation _ (pointwise_relation _ ((pointwise_relation _ (pointwise_relation _ Basics.impl))) ==> Basics.impl)))) ==>
     pointwise_relation _ (
     pointwise_relation _ (
     pointwise_relation _ (
     pointwise_relation _ (
     (pointwise_relation _ (pointwise_relation _ (pointwise_relation _ Basics.impl))) ==>
     Basics.impl)))))) WeakestPrecondition.func.
  Proof.
    cbv [Proper respectful pointwise_relation Basics.flip Basics.impl  WeakestPrecondition.func]; intros.
    destruct a. destruct p.
    destruct H1; intuition idtac.
    eexists.
    split; [eauto|].
    eapply Proper_cmd;
      cbv [Proper respectful pointwise_relation Basics.flip Basics.impl  WeakestPrecondition.func];
      try solve [typeclasses eauto with core].
    intros.
    eapply Proper_list_map;
      cbv [Proper respectful pointwise_relation Basics.flip Basics.impl  WeakestPrecondition.func];
      try solve [typeclasses eauto with core].
    - intros.
      eapply Proper_get;
        cbv [Proper respectful pointwise_relation Basics.flip Basics.impl  WeakestPrecondition.func];
        eauto.
    - eauto.
  Qed.

  Global Instance Proper_call :
    Proper (
     (pointwise_relation _ (
     (pointwise_relation _ (
     pointwise_relation _ (
     pointwise_relation _ (
     pointwise_relation _ (
     (pointwise_relation _ (pointwise_relation _ (pointwise_relation _ Basics.impl))) ==>
     Basics.impl)))))))) WeakestPrecondition.call.
  Proof.
    cbv [Proper respectful pointwise_relation Basics.impl]; ind_on (list (String.string * (list String.string * list String.string * Syntax.cmd.cmd)));
      cbn in *; intuition (try typeclasses eauto with core).
    destruct a.
    destruct (String.eqb s a1); eauto.
    eapply Proper_func;
      cbv [Proper respectful pointwise_relation Basics.flip Basics.impl  WeakestPrecondition.func];
      eauto.
  Qed.

  Global Instance Proper_program :
    Proper (
     pointwise_relation _ (
     pointwise_relation _ (
     pointwise_relation _ (
     pointwise_relation _ (
     pointwise_relation _ (
     (pointwise_relation _ (pointwise_relation _ (pointwise_relation _ Basics.impl))) ==>
     Basics.impl)))))) WeakestPrecondition.program.
  Proof.
    cbv [Proper respectful pointwise_relation Basics.impl  WeakestPrecondition.program]; intros.
    eapply Proper_cmd;
    cbv [Proper respectful pointwise_relation Basics.flip Basics.impl  WeakestPrecondition.func];
    try solve [typeclasses eauto with core].
    intros.
    eapply Proper_call;
    cbv [Proper respectful pointwise_relation Basics.flip Basics.impl  WeakestPrecondition.func];
    solve [typeclasses eauto with core].
  Qed.

  Ltac t :=
      repeat match goal with
             | |- forall _, _ => progress intros
             | H: exists _, _ |- _ => destruct H
             | H: and _ _ |- _ => destruct H
             | H: eq _ ?y |- _ => subst y
             | H: False |- _ => destruct H
             | _ => progress cbn in *
             | _ => progress cbv [dlet.dlet WeakestPrecondition.dexpr WeakestPrecondition.dexprs WeakestPrecondition.store] in *
             end; eauto.

  Lemma expr_sound m l e mc post (H : WeakestPrecondition.expr m l e post)
    : exists v mc', Semantics.eval_expr m l e mc = Some (v, mc') /\ post v.
  Proof.
    ind_on Syntax.expr; t.
    { destruct H. destruct H. eexists. eexists. rewrite H. eauto. }
    { eapply IHe in H; t. cbv [WeakestPrecondition.load] in H0; t. rewrite H. rewrite H0. eauto. }
    { eapply IHe in H; t. cbv [WeakestPrecondition.load] in H0; t. rewrite H. rewrite H0. eauto. }
    { eapply IHe1 in H; t. eapply IHe2 in H0; t. rewrite H, H0; eauto. }
    { eapply IHe1 in H; t. rewrite H. Tactics.destruct_one_match.
      { eapply IHe3 in H0; t. }
      { eapply IHe2 in H0; t. } }
  Qed.

  Lemma sound_args : forall m l args mc P,
      WeakestPrecondition.list_map (WeakestPrecondition.expr m l) args P ->
      exists x mc', Semantics.evaluate_call_args_log m l args mc = Some (x, mc') /\ P x.
  Proof.
    induction args; cbn; repeat (subst; t).
    unfold Semantics.eval_expr in *.
    eapply expr_sound in H; t; rewrite H.
    eapply IHargs in H0; t; rewrite H0.
    eauto.
  Qed.

  Lemma sound_getmany l a P :
    WeakestPrecondition.list_map (WeakestPrecondition.get l) a P
    -> exists vs, map.getmany_of_list l a = Some vs /\ P vs.
  Proof.
    cbv [map.getmany_of_list] in *.
    revert P l; induction a; cbn; repeat (subst; t).
    cbv [WeakestPrecondition.get] in H; t.
    epose proof (IHa _ l _); clear IHa; t.
    rewrite H. erewrite H1. eexists; split; eauto. exact H2.
    Unshelve.
    eapply Proper_list_map; try exact H0.
    all : cbv [respectful pointwise_relation Basics.impl WeakestPrecondition.get]; intros; cbv beta; t.
  Qed.

  Local Notation semantics_call := (fun e n t m args post =>
    exists params rets fbody, map.get e n = Some (params, rets, fbody) /\
    exists lf, map.putmany_of_list_zip params args map.empty = Some lf /\
    forall mc', Semantics.exec e fbody t m lf mc' (fun t' m' st1 mc'' =>
      exists retvs, map.getmany_of_list st1 rets = Some retvs /\
      post t' m' retvs)).

  Local Hint Constructors Semantics.exec : core.
  Lemma sound_cmd' e c t m l mc post
        (H:WeakestPrecondition.cmd (semantics_call e) c t m l post)
    : Semantics.exec e c t m l mc (fun t' m' l' mc' => post t' m' l').
  Proof.
    ind_on Syntax.cmd; repeat (t; try match reverse goal with H : WeakestPrecondition.expr _ _ _ _ |- _ => eapply expr_sound in H end).
    { destruct (BinInt.Z.eq_dec (Interface.word.unsigned x) (BinNums.Z0)) as [Hb|Hb]; cycle 1.
      { econstructor; t. }
      { eapply Semantics.exec.if_false; t. } }
    { revert dependent l; revert dependent m; revert dependent t; revert dependent mc; pattern x2.
      eapply (well_founded_ind H); t.
      pose proof (H1 _ _ _ _ ltac:(eassumption));
        repeat (t; try match goal with H : WeakestPrecondition.expr _ _ _ _ |- _ => eapply expr_sound in H end).
      { destruct (BinInt.Z.eq_dec (Interface.word.unsigned x4) (BinNums.Z0)) as [Hb|Hb].
        { eapply Semantics.exec.while_false; t. }
        { eapply Semantics.exec.while_true; t. t. } } }
    { eapply sound_args in H; t. }
    { eapply sound_args in H; t. }
  Qed.

  Section WithE.
    Context fs (E: env) (HE: List.Forall (fun '(k, v) => map.get E k = Some v) fs).
    Import coqutil.Tactics.Tactics.
    Lemma sound_call' n t m args post
      (H : WeakestPrecondition.call fs n t m args post)
      : semantics_call E n t m args post.
    Proof.
      revert H; revert post args m t n; induction HE; intros.
      { contradiction H. }
      destruct x as [n' ((X&Y)&Z)]; t.
      destr (String.eqb n' n); t.
      eexists X, Y, Z; split; [assumption|].
      eexists; eauto.
      eexists; eauto.
      intros.
      eapply sound_cmd'.
      eapply Proper_cmd; try eapply H0.
      all : cbv [respectful pointwise_relation Basics.impl]; intros; cbv beta.
      1: eapply IHf, Proper_call; eauto.
      2: eassumption.
      eauto using sound_getmany.
    Qed.

    Lemma sound_cmd'' c t m l mc post
      (H : WeakestPrecondition.cmd (WeakestPrecondition.call fs) c t m l post)
      : Semantics.exec E c t m l mc (fun t' m' l' mc' => post t' m' l').
    Proof.
      eapply Proper_cmd in H; [ .. | reflexivity ].
      1: apply sound_cmd'; exact H.
      cbv [respectful pointwise_relation Basics.impl]; intros; cbv beta.
      eapply sound_call', Proper_call, H1.
      cbv [respectful pointwise_relation Basics.impl]; eauto.
    Qed.
  End WithE.

  Lemma sound_cmd fs c t m l mc post
    (Hnd : List.NoDup (List.map fst fs))
    (H : WeakestPrecondition.cmd (WeakestPrecondition.call fs) c t m l post)
    : Semantics.exec (map.of_list fs) c t m l mc (fun t' m' l' mc' => post t' m' l').
  Proof.
    eapply sound_cmd'';
      try eapply Properties.map.all_gets_from_map_of_NoDup_list; eauto.
  Qed.

  (** Ad-hoc lemmas here? *)

  Import bedrock2.Syntax bedrock2.Semantics bedrock2.WeakestPrecondition.
  Lemma interact_nomem call action binds arges t m l post
        args (Hargs : dexprs m l arges args)
        (Hext : ext_spec t map.empty binds args (fun mReceive (rets : list word) =>
           mReceive = map.empty /\
           exists l0 : locals, map.putmany_of_list_zip action rets l = Some l0 /\
           post (cons (map.empty, binds, args, (map.empty, rets)) t) m l0))
    : WeakestPrecondition.cmd call (cmd.interact action binds arges) t m l post.
  Proof.
    exists args; split; [exact Hargs|].
    exists m.
    exists map.empty.
    split; [eapply Properties.map.split_empty_r; exact eq_refl|].
    eapply ext_spec.weaken; [|eapply Hext]; intros ? ? [? [? []]]. subst a; subst.
    eexists; split; [eassumption|].
    intros. eapply Properties.map.split_empty_r in H. subst. assumption.
  Qed.

  Lemma intersect_expr: forall m l e (post1 post2: word -> Prop),
      WeakestPrecondition.expr m l e post1 ->
      WeakestPrecondition.expr m l e post2 ->
      WeakestPrecondition.expr m l e (fun v => post1 v /\ post2 v).
  Proof.
    induction e; cbn; unfold literal, dlet.dlet, WeakestPrecondition.get; intros.
    - eauto.
    - decompose [and ex] H. decompose [and ex] H0. assert (x0 = x1) by congruence. subst. eauto.
    - eapply Proper_expr.
      2: eapply IHe.
      2: eapply H.
      2: eapply H0.
      unfold Morphisms.pointwise_relation, Basics.impl.
      unfold load. intros. decompose [and ex] H1. assert (x0 = x) by congruence. subst. eauto.
    - eapply Proper_expr.
      2: eapply IHe.
      2: eapply H.
      2: eapply H0.
      unfold Morphisms.pointwise_relation, Basics.impl.
      unfold load. intros. decompose [and ex] H1. assert (x0 = x) by congruence. subst. eauto.
    - eapply Proper_expr.
      2: eapply IHe1.
      2: eapply H.
      2: eapply H0.
      unfold Morphisms.pointwise_relation, Basics.impl.
      unfold load. intros. decompose [and ex] H1.
      eapply IHe2; eassumption.
    - eapply Proper_expr.
      2: eapply IHe1.
      2: eapply H.
      2: eapply H0.
      unfold Morphisms.pointwise_relation, Basics.impl.
      intros ? [? ?]. Tactics.destruct_one_match; eauto using Proper_expr.
  Qed.

  Lemma dexpr_expr (m : mem) l e P
    (H : WeakestPrecondition.expr m l e P)
    : exists v, WeakestPrecondition.dexpr m l e v /\ P v.
  Proof.
    revert dependent P; induction e; cbn.
    { cbv [WeakestPrecondition.literal dlet.dlet]; cbn; eauto. }
    { cbv [WeakestPrecondition.get]; intros ?(?&?&?); eauto. }
    { intros v H; case (IHe _ H) as (?&?&?&?&?); clear IHe H.
      cbv [WeakestPrecondition.dexpr] in *.
      eexists; split; [|eassumption].
      eapply Proper_expr; [|eauto].
      intros ? ?; subst.
      eexists; eauto. }
    { intros v H; case (IHe _ H) as (?&?&?&?&?); clear IHe H.
      cbv [WeakestPrecondition.dexpr] in *.
      eexists; split; [|eassumption].
      eapply Proper_expr; [|eauto].
      intros ? ?; subst.
      eexists; eauto. }
    { intros P H.
      case (IHe1 _ H) as (?&?&H'); case (IHe2 _ H') as (?&?&?);
      clear IHe1 IHe2 H H'.
      cbv [WeakestPrecondition.dexpr] in *.
      eexists; split; [|eassumption].
      eapply Proper_expr; [|eauto]; intros ? [].
      eapply Proper_expr; [|eauto]; intros ? [].
      trivial.
    }
    { intros P H.
      case (IHe1 _ H) as (?&?&H'). Tactics.destruct_one_match_hyp.
      { case (IHe3 _ H') as (?&?&?).
        clear IHe1 IHe2 H H'.
        cbv [WeakestPrecondition.dexpr] in *.
        eexists; split; [|eassumption].
        eapply Proper_expr; [|eauto]; intros ? [].
        rewrite word.eqb_eq by reflexivity. assumption. }
      { case (IHe2 _ H') as (?&?&?).
        clear IHe1 IHe3 H H'.
        cbv [WeakestPrecondition.dexpr] in *.
        eexists; split; [|eassumption].
        eapply Proper_expr; [|eauto]; intros ? [].
        Tactics.destruct_one_match. 1: contradiction. assumption. } }
  Qed.
End WeakestPrecondition.


  Lemma same_next :
    forall x y,
      (x! = R0 //\\ y! = R0 |-- x! = y!).
  Proof. solve_linear. Qed.

  Lemma UpperLower_X_Proposed_refine :
    forall t,
      (UpperLower_X.Monitor.SafeAcc t //\\ "a"! = t
       |-- UpperLower_X.Monitor.SafeAcc "a"!).
  Proof.
    breakAbstraction. solve_linear. rewrite H1 in *.
    solve_linear.
  Qed.

(*
  Definition refined_UpperLower_X_SpecR :
    { ins : list Var &
       { outs : list Var &
           { p : Parallel ins outs &
                 tlaParD p |--
                 Prog (projT1 UpperLower_X_SpecR)} } }.
  Proof.
    Opaque UpperLower_X.Monitor.SafeAcc
           UpperLower_X.Monitor.Default.
    eexists. eexists. eexists. simpl. restoreAbstraction.
    match goal with
    | [ |- context [ rename_formula ?m _ ] ]
      => remember m as rx
    end.
    match goal with
    | [ |- context
             [ rename_formula _ (rename_formula ?m _) ] ]
      => remember m as rm
    end.
    repeat rewrite minus_eq.
    rewrite land_distr.
    apply par_disjoint_refine.
    { repeat rewrite land_lor_distr_R.
      pose proof UpperLower_X_Proposed_refine
        as Hrefine. specialize (Hrefine "A").
      apply (Proper_Rename rx rx) in Hrefine;
        [ | reflexivity].
      rewrite <- Rename_ok in Hrefine.
      rewrite <- Rename_ok in Hrefine.
      rewrite <- Hrefine at 1. clear Hrefine.
      pose proof UpperLower_X_Proposed_refine as Hrefine.
      specialize (Hrefine "A").
      apply (Proper_Rename rm rm) in Hrefine;
        [ | reflexivity].
      apply (Proper_Rename rx rx) in Hrefine;
        [ | reflexivity].
      rewrite <- Rename_ok with (m:=rm) in Hrefine.
      rewrite <- Rename_ok with (m:=rm) in Hrefine.
      rewrite <- Rename_ok with (m:=rx) in Hrefine.
      rewrite <- Rename_ok with (m:=rx) in Hrefine.
      rewrite <- Hrefine at 1. clear Hrefine.
      repeat rewrite lorA.
      Transparent UpperLower_X.Monitor.SafeAcc
                  UpperLower_X.Monitor.Default.
      subst. simpl. restoreAbstraction.
      repeat rewrite minus_eq. rewrite land_distr.
      apply ite_refine.
      { reflexivity. }
      { apply Assign_refine; reflexivity. }
      { rewrite <- lor_intro2. rewrite <- lor_intro2.
        apply ite_refine_and_impl.
        { reflexivity. }
        { solve_linear. }
        { apply ite_refine_and_impl.
          { reflexivity. }
          { solve_linear. }
          { rewrite <- leq_eq_refine.
            apply Assign_refine; reflexivity. }
          { rewrite <- leq_eq_refine.
            apply Assign_refine; reflexivity. } }
        { apply ite_refine_and_impl.
          { reflexivity. }
          { solve_linear. }
          { rewrite <- leq_eq_refine.
            rewrite minus_0_l_equiv.
            rewrite <- neg_eq.
            apply Assign_refine; reflexivity. }
          { rewrite <- leq_eq_refine.
            rewrite minus_0_l_equiv.
            rewrite <- neg_eq.
            apply Assign_refine; reflexivity. } } }
      admit.
      admit.
      admit.
      admit.
      admit.
      admit.
      admit.
      admit.
      admit.
      admit.
      admit.
      admit. }
    { rewrite landtrueR.
      rewrite <- same_next.
      repeat apply par_disjoint_refine;
      try (apply Assign_refine; reflexivity). }
    Grab Existential Variables.
    { decide_disjoint_var_sets. }
    { decide_disjoint_var_sets. }
    { decide_disjoint_var_sets. }
    { decide_disjoint_var_sets. }
    { decide_disjoint_var_sets. }
    { decide_disjoint_var_sets. }
  Defined.
*)


Require Import Kami.AllNotations ProcKami.FU ProcKami.Div.
Require Import ProcKami.RiscvIsaSpec.Insts.Alu.AluFuncs.
Require Import List.

Section Alu.
  Context `{procParams: ProcParams}.

  Section Ty.
    Variable ty: Kind -> Type.

    Definition AddInputType
      := STRUCT_TYPE {
           "xlen"  :: XlenValue;
           "arg1" :: Bit (Xlen + 1);
           "arg2" :: Bit (Xlen + 1)
         }.

    Definition AddOutputType
      := STRUCT_TYPE {
           "xlen" :: XlenValue;
           "res" :: Bit (Xlen + 1)
         }.

    Local Open Scope kami_expr.

    Definition Add: FUEntry :=
      {| fuName := "add" ;
         fuFunc := (fun ty i => LETE x: AddInputType <- i;
                               LETC a: Bit (Xlen + 1) <- #x @% "arg1";
                               LETC b: Bit (Xlen + 1) <- #x @% "arg2";
                               LETC res: Bit (Xlen + 1) <- #a + #b ;
                               RetE
                                 (STRUCT {
                                    "xlen" ::= #x @% "xlen";
                                    "res" ::= #res
                                  } : AddOutputType @# ty)) ;
         fuInsts := {| instName     := "addi" ;
                       xlens        := xlens_all;
                       extensions   := "I" :: nil;
                       ext_ctxt_off := nil;
                       uniqId       := fieldVal instSizeField ('b"11") ::
                                                fieldVal opcodeField ('b"00100") ::
                                                fieldVal funct3Field ('b"000") :: nil ;
                       inputXform   := (fun ty (cfg_pkt : ContextCfgPkt @# ty) gcpin => LETE gcp: ExecContextPkt <- gcpin;
                                                       RetE ((STRUCT { "xlen"  ::= (cfg_pkt @% "xlen");
                                                                       "arg1" ::= xlen_sign_extend (Xlen + 1) (cfg_pkt @% "xlen") (#gcp @% "reg1");
                                                                       "arg2" ::= SignExtendTruncLsb (Xlen + 1) (imm (#gcp @% "inst"))
                                                             }): AddInputType @# _)) ;
                       outputXform  := (fun ty (resultExpr : AddOutputType ## ty)
                                         => LETE res <- resultExpr;
                                            RetE (intRegTag (xlen_sign_extend Rlen (#res @% "xlen") (#res @% "res")))) ;
                       optMemParams  := None ;
                       instHints    := falseHints<|hasRs1 := true|><|hasRd := true|>
                    |} ::
                       {| instName     := "slti" ;
                          xlens        := xlens_all;
                          extensions   := "I" :: nil;
                          ext_ctxt_off := nil;
                          uniqId       := fieldVal instSizeField ('b"11") ::
                                                   fieldVal opcodeField ('b"00100") ::
                                                   fieldVal funct3Field ('b"010") :: nil ;
                          inputXform   := (fun ty (cfg_pkt : ContextCfgPkt @# ty) gcpin => LETE gcp: ExecContextPkt <- gcpin;
                                                          RetE ((STRUCT { "xlen"  ::= (cfg_pkt @% "xlen");
                                                                          "arg1" ::= xlen_sign_extend (Xlen + 1) (cfg_pkt @% "xlen") (#gcp @% "reg1");
                                                                          "arg2" ::= neg (SignExtendTruncLsb
                                                                                (Xlen + 1) (imm (#gcp @% "inst")))
                                                                }): AddInputType @# _)) ;
                          outputXform  := (fun ty (resultExpr : AddOutputType ## ty)
                                            => LETE res <- resultExpr;
                                               LETC resultMsb: Bit 1 <- UniBit (TruncMsb _ 1) (#res @% "res");
                                               RetE (intRegTag (ZeroExtendTruncLsb Rlen #resultMsb)));
                          optMemParams  := None ;
                          instHints    := falseHints<|hasRs1 := true|><|hasRd := true|>
                       |} ::
                       {| instName     := "sltiu" ;
                          xlens        := xlens_all;
                          extensions   := "I" :: nil;
                          ext_ctxt_off := nil;
                          uniqId       := fieldVal instSizeField ('b"11") ::
                                                   fieldVal opcodeField ('b"00100") ::
                                                   fieldVal funct3Field ('b"011") :: nil ;
                          inputXform   := (fun ty (cfg_pkt : ContextCfgPkt @# ty) gcpin
                                             => LETE gcp: ExecContextPkt <- gcpin;
                                                RetE
                                                  ((STRUCT {
                                                    "xlen"  ::= (cfg_pkt @% "xlen");
                                                    "arg1" ::= ZeroExtendTruncLsb (Xlen + 1) (xlen_sign_extend (Xlen) (cfg_pkt @% "xlen") (#gcp @% "reg1"));
                                                    "arg2" ::= neg (ZeroExtendTruncLsb (Xlen + 1) (SignExtendTruncLsb Xlen (imm (#gcp @% "inst"))))
                                                  }): AddInputType @# _)) ;
                          outputXform  := (fun ty (resultExpr : AddOutputType ## ty)
                                            => LETE res <- resultExpr;
                                               LETC resultMsb: Bit 1 <- UniBit (TruncMsb _ 1) (#res @% "res");
                                               RetE (intRegTag (ZeroExtendTruncLsb Rlen #resultMsb))) ;
                          optMemParams  := None ;
                          instHints    := falseHints<|hasRs1 := true|><|hasRd := true|>
                       |} ::
                       {| instName     := "add" ;
                          xlens        := xlens_all;
                          extensions   := "I" :: nil;
                          ext_ctxt_off := nil;
                          uniqId       := fieldVal instSizeField ('b"11") ::
                                                   fieldVal opcodeField ('b"01100") ::
                                                   fieldVal funct3Field ('b"000") ::
                                                   fieldVal funct7Field ('b"0000000") :: nil ;
                          inputXform   := (fun ty (cfg_pkt : ContextCfgPkt @# ty) gcpin => LETE gcp: ExecContextPkt <- gcpin;
                                                          RetE ((STRUCT { "xlen"  ::= (cfg_pkt @% "xlen");
                                                                          "arg1" ::= xlen_sign_extend (Xlen + 1) (cfg_pkt @% "xlen") (#gcp @% "reg1");
                                                                          "arg2" ::= xlen_sign_extend (Xlen + 1) (cfg_pkt @% "xlen") (#gcp @% "reg2")
                                                                }): AddInputType @# _)) ;
                          outputXform  := (fun ty (resultExpr : AddOutputType ## ty)
                                            => LETE res <- resultExpr;
                                               RetE (intRegTag (xlen_sign_extend Rlen (#res @% "xlen") (#res @% "res")))) ;
                          optMemParams  := None ;
                          instHints    := falseHints<|hasRs1 := true|><|hasRs2 := true|><|hasRd := true|>
                       |} ::
                       {| instName     := "sub" ;
                          xlens        := xlens_all;
                          extensions   := "I" :: nil;
                          ext_ctxt_off := nil;
                          uniqId       := fieldVal instSizeField ('b"11") ::
                                                   fieldVal opcodeField ('b"01100") ::
                                                   fieldVal funct3Field ('b"000") ::
                                                   fieldVal funct7Field ('b"0100000") :: nil ;
                          inputXform   := (fun ty (cfg_pkt : ContextCfgPkt @# ty) gcpin => LETE gcp: ExecContextPkt <- gcpin;
                                                          RetE ((STRUCT { "xlen"  ::= (cfg_pkt @% "xlen");
                                                                          "arg1" ::= xlen_sign_extend (Xlen + 1) (cfg_pkt @% "xlen") (#gcp @% "reg1");
                                                                          "arg2" ::= neg (xlen_sign_extend (Xlen + 1) (cfg_pkt @% "xlen") (#gcp @% "reg2"))
                                                                }): AddInputType @# _)) ;
                          outputXform  := (fun ty (resultExpr : AddOutputType ## ty)
                                            => LETE res <- resultExpr;
                                               RetE (intRegTag (xlen_sign_extend Rlen (#res @% "xlen") (#res @% "res")))) ;
                          optMemParams  := None ;
                          instHints    := falseHints<|hasRs1 := true|><|hasRs2 := true|><|hasRd := true|>
                       |} ::
                       {| instName     := "slt" ;
                          xlens        := xlens_all;
                          extensions   := "I" :: nil;
                          ext_ctxt_off := nil;
                          uniqId       := fieldVal instSizeField ('b"11") ::
                                                   fieldVal opcodeField ('b"01100") ::
                                                   fieldVal funct3Field ('b"010") ::
                                                   fieldVal funct7Field ('b"0000000") :: nil ;
                          inputXform   := (fun ty (cfg_pkt : ContextCfgPkt @# ty) gcpin => LETE gcp: ExecContextPkt <- gcpin;
                                                          RetE ((STRUCT { "xlen"  ::= (cfg_pkt @% "xlen");
                                                                          "arg1" ::= xlen_sign_extend (Xlen + 1) (cfg_pkt @% "xlen") (#gcp @% "reg1");
                                                                          "arg2" ::= neg (xlen_sign_extend (Xlen + 1) (cfg_pkt @% "xlen") (#gcp @% "reg2"))
                                                                }): AddInputType @# _)) ;
                          outputXform  := (fun ty (resultExpr : AddOutputType ## ty)
                                            => LETE res <- resultExpr;
                                               LETC resultMsb : Bit 1 <- UniBit (TruncMsb _ 1) (#res @% "res") ;
                                               RetE (intRegTag (ZeroExtendTruncLsb Rlen (#resultMsb)))) ;
                          optMemParams  := None ;
                          instHints    := falseHints<|hasRs1 := true|><|hasRs2 := true|><|hasRd := true|>
                       |} ::
                       {| instName     := "sltu" ;
                          xlens        := xlens_all;
                          extensions   := "I" :: nil;
                          ext_ctxt_off := nil;
                          uniqId       := fieldVal instSizeField ('b"11") ::
                                                   fieldVal opcodeField ('b"01100") ::
                                                   fieldVal funct3Field ('b"011") ::
                                                   fieldVal funct7Field ('b"0000000") :: nil ;
                          inputXform   := (fun ty (cfg_pkt : ContextCfgPkt @# ty) gcpin
                                            => LETE gcp: ExecContextPkt <- gcpin;
                                               RetE ((STRUCT {
                                                 "xlen"  ::= (cfg_pkt @% "xlen");
                                                 "arg1" ::= xlen_zero_extend (Xlen + 1) (cfg_pkt @% "xlen") (#gcp @% "reg1");
                                                 "arg2" ::= neg (xlen_zero_extend (Xlen + 1) (cfg_pkt @% "xlen") (#gcp @% "reg2"))
                                               }): AddInputType @# _)) ;
                          outputXform  := (fun ty (resultExpr : AddOutputType ## ty)
                                            => LETE res <- resultExpr;
                                               LETC resultMsb: Bit 1 <- UniBit (TruncMsb _ 1) (#res @% "res");
                                               RetE (intRegTag (ZeroExtendTruncLsb Rlen (#resultMsb)))) ;
                          optMemParams  := None ;
                          instHints    := falseHints<|hasRs1 := true|><|hasRs2 := true|><|hasRd := true|>
                       |} ::
                       {| instName     := "addiw" ;
                          xlens        :=  (Xlen64 :: nil);
                          extensions   := "I" :: nil;
                          ext_ctxt_off := nil;
                          uniqId
                            := fieldVal instSizeField ('b"11") ::
                               fieldVal opcodeField ('b"00110") ::
                               fieldVal funct3Field ('b"000") ::
                               nil;
                          inputXform
                            := fun ty (cfg_pkt : ContextCfgPkt @# ty) gcpin
                                 => LETE gcp
                                      :  ExecContextPkt
                                      <- gcpin;
                                    RetE
                                      (STRUCT {
                                         "xlen"  ::= (cfg_pkt @% "xlen");
                                         "arg1" ::= sign_extend_trunc 32 (Xlen + 1) (#gcp @% "reg1");
                                         "arg2" ::= SignExtendTruncLsb (Xlen + 1) (imm (#gcp @% "inst"))
                                       }: AddInputType @# _);
                          outputXform
                            := fun ty (resultExpr : AddOutputType ## ty)
                                 => LETE res <- resultExpr;
                                    RetE (intRegTag (sign_extend_trunc 32 Rlen (#res @% "res")));
                          optMemParams  := None ;
                          instHints    := falseHints<|hasRs1 := true|><|hasRd := true|>
                       |} ::
                       {| instName     := "addw" ;
                          xlens        :=  (Xlen64 :: nil);
                          extensions   := "I" :: nil;
                          ext_ctxt_off := nil;
                          uniqId       := fieldVal instSizeField ('b"11") ::
                                                   fieldVal opcodeField ('b"01110") ::
                                                   fieldVal funct3Field ('b"000") ::
                                                   fieldVal funct7Field ('b"0000000") :: nil ;
                          inputXform   := (fun ty (cfg_pkt : ContextCfgPkt @# ty) gcpin => LETE gcp: ExecContextPkt <- gcpin;
                                                          RetE ((STRUCT { "xlen"  ::= (cfg_pkt @% "xlen");
                                                                          "arg1" ::= xlen_sign_extend (Xlen + 1) (cfg_pkt @% "xlen") (#gcp @% "reg1");
                                                                          "arg2" ::= xlen_sign_extend (Xlen + 1) (cfg_pkt @% "xlen") (#gcp @% "reg2")
                                                                }): AddInputType @# _)) ;
                          outputXform  := (fun ty (resultExpr : AddOutputType ## ty)
                                            => LETE res <- resultExpr;
                                               RetE (intRegTag (sign_extend_trunc 32 Rlen (#res @% "res")))) ;
                          optMemParams  := None ;
                          instHints    := falseHints<|hasRs1 := true|><|hasRs2 := true|><|hasRd := true|>
                       |} ::
                       {| instName     := "subw" ;
                          xlens        :=  (Xlen64 :: nil);
                          extensions   := "I" :: nil;
                          ext_ctxt_off := nil;
                          uniqId       := fieldVal instSizeField ('b"11") ::
                                                   fieldVal opcodeField ('b"01110") ::
                                                   fieldVal funct3Field ('b"000") ::
                                                   fieldVal funct7Field ('b"0100000") :: nil ;
                          inputXform   := (fun ty (cfg_pkt : ContextCfgPkt @# ty) gcpin => LETE gcp: ExecContextPkt <- gcpin;
                                                          RetE ((STRUCT { "xlen"  ::= (cfg_pkt @% "xlen");
                                                                          "arg1" ::= xlen_sign_extend (Xlen + 1) (cfg_pkt @% "xlen") (#gcp @% "reg1");
                                                                          "arg2" ::= neg (xlen_sign_extend (Xlen + 1) (cfg_pkt @% "xlen") (#gcp @% "reg2"))
                                                                }): AddInputType @# _)) ;
                          outputXform  := (fun ty (resultExpr : AddOutputType ## ty)
                                            => LETE res <- resultExpr;
                                               RetE (intRegTag (sign_extend_trunc 32 Rlen (#res @% "res"))));
                          optMemParams  := None ;
                          instHints    := falseHints<|hasRs1 := true|><|hasRs2 := true|><|hasRd := true|>
                       |} ::
                       {| instName     := "lui" ;
                          xlens        := xlens_all;
                          extensions   := "I" :: nil;
                          ext_ctxt_off := nil;
                          uniqId
                            := fieldVal instSizeField ('b"11") ::
                               fieldVal opcodeField ('b"01101") ::
                               nil;
                          inputXform
                            := fun ty (cfg_pkt : ContextCfgPkt @# ty) gcpin
                                 => LETE gcp
                                      :  ExecContextPkt
                                      <- gcpin;
                                    LETC imm
                                      :  Bit 32
                                      <- {<
                                           UniBit (TruncMsb 12 20) (#gcp @% "inst"),
                                           $$(natToWord 12 0)
                                         >};
                                    RetE
                                      (STRUCT {
                                         "xlen"  ::= (cfg_pkt @% "xlen");
                                         "arg1" ::= SignExtendTruncLsb (Xlen + 1) #imm;
                                         "arg2" ::= $0
                                       }: AddInputType @# _);
                          outputXform
                            := fun ty (resultExpr : AddOutputType ## ty)
                                 => LETE res <- resultExpr;
                                    RetE (intRegTag (xlen_sign_extend Rlen (#res @% "xlen") (#res @% "res")));
                          optMemParams  := None ;
                          instHints    := falseHints<|hasRd := true|>
                       |} ::
                       {| instName     := "auipc" ;
                          xlens        := xlens_all;
                          extensions   := "I" :: nil;
                          ext_ctxt_off := nil;
                          uniqId
                            := fieldVal instSizeField ('b"11") ::
                               fieldVal opcodeField ('b"00101") ::
                               nil;
                          inputXform
                            := fun ty (cfg_pkt : ContextCfgPkt @# ty) gcpin
                                 => LETE gcp: ExecContextPkt <- gcpin;
                                    RetE
                                      (STRUCT {
                                         "xlen" ::= (cfg_pkt @% "xlen");
                                         "arg1"
                                           ::= SignExtendTruncLsb (Xlen + 1)
                                                 ({<
                                                   ZeroExtendTruncMsb 20 (#gcp @% "inst"),
                                                   $$(natToWord 12 0)
                                                 >});
                                         "arg2" ::= xlen_sign_extend (Xlen + 1) (cfg_pkt @% "xlen") (#gcp @% "pc")
                                       }: AddInputType @# _);
                          outputXform
                            := fun ty (resultExpr : AddOutputType ## ty)
                                 => LETE res <- resultExpr;
                                    RetE (intRegTag (xlen_sign_extend Rlen (#res @% "xlen") (#res @% "res")));
                          optMemParams  := None ;
                          instHints    := falseHints<|hasRd := true|>
                       |} ::
                       nil

      |}.

    Local Close Scope kami_expr.

  End Ty.

End Alu.


Require Import oeuf.Common.
Require oeuf.StepLib.
Require Import Psatz.

Require Import oeuf.Utopia.
Require Import oeuf.Monads.

Require Export oeuf.HigherValue.
Require Import oeuf.AllValues.
Require Import oeuf.OpaqueOps.
Require Import oeuf.ListLemmas.

Inductive expr :=
| Arg
| Self
| Var (i : nat)
| Deref (e : expr) (off : nat)
.

Inductive stmt :=
| Skip
| Seq (s1 : stmt) (s2 : stmt)
| Call (dst : nat) (f : expr) (a : expr)
| MkConstr (dst : nat) (tag : nat) (args : list expr)
| Switch (dst : nat) (cases : list stmt)
| MkClose (dst : nat) (f : function_name) (free : list expr)
| OpaqueOp (dst : nat) (op : opaque_oper_name) (args : list expr)
| Assign (dst : nat) (e : expr)
.

Definition env := list (stmt * expr).

(* Continuation-based step relation *)

Record frame := Frame {
    arg : value;
    self : value;
    locals : list (nat * value)
}.

Definition set f l v :=
    Frame (arg f) (self f) ((l, v) :: locals f).

Definition local f l := lookup (locals f) l.

Inductive cont :=
| Kseq (code : stmt) (k : cont)
| Kswitch (k : cont)
| Kreturn (ret : expr) (k : cont)
| Kcall (dst : nat) (f : frame) (k : cont)
| Kstop (ret : expr).

Inductive state :=
| Run (s : stmt) (f : frame) (k : cont)
| Return (v : value) (k : cont)
| Stop (v : value).

Inductive eval : frame -> expr -> value -> Prop :=
| EArg : forall f,
        eval f Arg (arg f)
| ESelf : forall f,
        eval f Self (self f)

| EVar : forall f i v,
        local f i = Some v ->
        eval f (Var i) v

| EDerefConstr : forall f e off tag args v,
        eval f e (Constr tag args) ->
        nth_error args off = Some v ->
        eval f (Deref e off) v
| EDerefClose : forall f e off fname free v,
        eval f e (Close fname free) ->
        nth_error free off = Some v ->
        eval f (Deref e off) v
.

Inductive sstep (E : env) : state -> state -> Prop :=
| SSeq : forall s1 s2 f k,
        sstep E (Run (Seq s1 s2) f k)
                (Run s1 f (Kseq s2 k))

| SConstrDone : forall dst tag args f k vs,
        Forall2 (eval f) args vs ->
        sstep E (Run (MkConstr dst tag args) f k)
                (Run Skip (set f dst (Constr tag vs)) k)
| SCloseDone : forall dst fname free f k vs,
        Forall2 (eval f) free vs ->
        sstep E (Run (MkClose dst fname free) f k)
                (Run Skip (set f dst (Close fname vs)) k)
| SOpaqueOpDone : forall dst op args f k vs v,
        Forall2 (eval f) args vs ->
        opaque_oper_denote_higher op vs = Some v ->
        sstep E (Run (OpaqueOp dst op args) f k)
                (Run Skip (set f dst v) k)

| SMakeCall : forall dst fe ae f k  fname free arg body ret,
        eval f fe (Close fname free) ->
        eval f ae arg ->
        nth_error E fname = Some (body, ret) ->
        sstep E (Run (Call dst fe ae) f k)
                (Run body (Frame arg (Close fname free) [])
                    (Kreturn ret (Kcall dst f k)))

(* NB: `Switch` still has an implicit target of `Arg` *)
| SSwitchinate : forall dst cases f k  tag args case,
        arg f = Constr tag args ->
        nth_error cases tag = Some case ->
        sstep E (Run (Switch dst cases) f k)
                (Run case f (Kswitch k))

| SAssign : forall dst src f k v,
        eval f src v ->
        sstep E (Run (Assign dst src) f k)
                (Run Skip (set f dst v) k)

| SContSeq : forall f s k,
        sstep E (Run Skip f (Kseq s k))
                (Run s f k)
| SContSwitch : forall f k,
        sstep E (Run Skip f (Kswitch k))
                (Run Skip f k)
| SContReturn : forall f ret k v,
        eval f ret v ->
        sstep E (Run Skip f (Kreturn ret k))
                (Return v k)
| SContCall : forall v dst f k,
        sstep E (Return v (Kcall dst f k))
                (Run Skip (set f dst v) k)
| SContStop : forall ret f v,
        eval f ret v ->
        sstep E (Run Skip f (Kstop ret))
                (Stop v)
.

Definition sstar BE := StepLib.sstar (sstep BE).
Definition SStarNil := @StepLib.SStarNil state.
Definition SStarCons := @StepLib.SStarCons state.

Definition splus BE := StepLib.splus (sstep BE).
Definition SPlusOne := @StepLib.SPlusOne state.
Definition SPlusCons := @StepLib.SPlusCons state.

Require Import oeuf.Metadata.
Require oeuf.Semantics.

Definition prog_type : Type := env * list metadata.
Definition val_level := VlHigher.
Definition valtype := value_type val_level.

Inductive is_callstate (prog : prog_type) : valtype -> valtype -> state -> Prop :=
| IsCallstate : forall fname free av body ret,
        nth_error (fst prog) fname = Some (body, ret) ->
        let fv := Close fname free in
        HigherValue.public_value (snd prog) fv ->
        HigherValue.public_value (snd prog) av ->
        is_callstate prog fv av
            (Run body
                 (Frame av fv [])
                 (Kstop ret)).

Inductive final_state (prog : prog_type) : state -> valtype -> Prop :=
| FinalState : forall v,
        HigherValue.public_value (snd prog) v ->
        final_state prog (Stop v) v.

Definition initial_env (prog : prog_type) : env := fst prog.

Definition semantics (prog : prog_type) : Semantics.semantics :=
  @Semantics.Semantics_gen state env val_level
                 (is_callstate prog)
                 (sstep)
                 (final_state prog)
                 (initial_env prog).

(*

Definition prog_type : Type := env * list metadata.

Inductive initial_state (prog : prog_type) : state -> Prop :=.

Inductive final_state (prog : prog_type) : state -> Prop :=
| FinalState : forall v, final_state prog (Stop v).

Definition initial_env (prog : prog_type) : env := fst prog.

Definition semantics (prog : prog_type) : Semantics.semantics :=
  @Semantics.Semantics_gen state env
                 (sstep)
                 (initial_state prog)
                 (final_state prog)
                 (initial_env prog).

*)

(*
 * Mutual recursion/induction schemes for expr
 *)

Definition stmt_rect_mut
        (P : stmt -> Type)
        (Pl : list stmt -> Type)
    (HSkip :    P Skip)
    (HSeq :     forall s1 s2, P s1 -> P s2 -> P (Seq s1 s2))
    (HCall :    forall dst f a, P (Call dst f a))
    (HConstr :  forall dst tag args, P (MkConstr dst tag args))
    (HSwitch :  forall dst cases, Pl cases -> P (Switch dst cases))
    (HClose :   forall dst fname free, P (MkClose dst fname free))
    (HOpaqueOp : forall dst op args, P (OpaqueOp dst op args))
    (HAssign :  forall dst src, P (Assign dst src))
    (Hnil :     Pl [])
    (Hcons :    forall i is, P i -> Pl is -> Pl (i :: is))
    (i : stmt) : P i :=
    let fix go i :=
        let fix go_list is :=
            match is as is_ return Pl is_ with
            | [] => Hnil
            | i :: is => Hcons i is (go i) (go_list is)
            end in
        match i as i_ return P i_ with
        | Skip => HSkip
        | Seq s1 s2 => HSeq s1 s2 (go s1) (go s2)
        | Call dst f a => HCall dst f a
        | MkConstr dst tag args => HConstr dst tag args
        | Switch dst cases => HSwitch dst cases (go_list cases)
        | MkClose dst fname free => HClose dst fname free
        | OpaqueOp dst op args => HOpaqueOp dst op args
        | Assign dst src => HAssign dst src
        end in go i.

(* Useful wrapper for `expr_rect_mut with (Pl := Forall P)` *)
Definition stmt_ind' (P : stmt -> Prop)
    (HSkip :    P Skip)
    (HSeq :     forall s1 s2, P s1 -> P s2 -> P (Seq s1 s2))
    (HCall :    forall dst f a, P (Call dst f a))
    (HConstr :  forall dst tag args, P (MkConstr dst tag args))
    (HSwitch :  forall dst cases, Forall P cases -> P (Switch dst cases))
    (HClose :   forall dst fname free, P (MkClose dst fname free))
    (HOpaqueOp : forall dst op args, P (OpaqueOp dst op args))
    (HAssign :  forall dst src, P (Assign dst src))
    (i : stmt) : P i :=
    ltac:(refine (@stmt_rect_mut P (Forall P)
        HSkip HSeq HCall HConstr HSwitch HClose HOpaqueOp HAssign _ _ i); eauto).