(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(** I64 builtins layer *)

Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Integers.
Require Import compcert.lib.Floats.
Require Import compcert.common.AST.
Require Import compcert.common.Values.
Require Import compcertx.backend.I64helpers.
Require Import compcert.backend.SelectLong.
Require Import compcertx.backend.SelectLongproofX.
Require Import liblayers.compat.CompatPrimSem.
Require Import liblayers.compat.CompatLayers.
Require Import liblayers.compat.CompatExternalCalls.
Require Import compcert.cfrontend.Ctypes.
Require Import liblayers.compcertx.Observation.

(** Missing lemma from [PseudoJoin] *)

Section WITHPSEUDOJOIN.
  Context `{PseudoJoin}.

  Lemma split_le_left:
    forall a b c,
      (a ⊕ b) ≤ c ->
      a ≤ c.
  Proof.
    intros. etransitivity. eapply left_upper_bound. eassumption.
  Qed.

  Lemma split_le_right:
    forall a b c,
      (a ⊕ b) ≤ c ->
      b ≤ c.
  Proof.
    intros until c.
    rewrite commutativity.
    eapply split_le_left.
  Qed.
End WITHPSEUDOJOIN.

Ltac split_le :=
  match goal with
    | [ H: ?a ⊕ ?b ≤ ?c |- _ ] =>
      let Hl := fresh H "l" in
      let Hr := fresh H "r" in
      generalize (split_le_left _ _ _ H);
        generalize (split_le_right _ _ _ H);
        clear H;
        intros Hr Hl
  end.

Section WITHSTENCIL.
Context `{Hobs: Observation}.
Context `{Hstencil: Stencil}.

Context `{Hmem: Mem.MemoryModel}.
Context `{Hmwd: UseMemWithData mem}.

Context {D: compatdata}.

  Definition csem_info step args res: sextcall_info (mem := mwd D) :=
    {|
      sextcall_step := step;
      sextcall_csig := mkcsig args res;
      sextcall_valid := const (B := stencil) true
    |}.

  Definition csem_full (sem: sextcall_info (mem := mwd D)) :=
    fun `{!ExtcallProperties sem} `{!ExtcallInvariants sem} =>
      {|
        sextcall_primsem_step := sem;
        sextcall_props := OK _;
        sextcall_invs := OK _
      |}.

  (** longoffloat *)

  Inductive sextcall_longoffloat_step (s: stencil) (WB: block -> Prop):
    list val -> mwd D -> val -> mwd D -> Prop :=
  | sextcall_longoffloat_step_intro
      x z
      (Hxz: Val.longoffloat x = Some z)
      m :
      sextcall_longoffloat_step s WB (x :: nil) m z m
  .

  Definition sextcall_longoffloat_info :=
    csem_info
      sextcall_longoffloat_step
      (Tcons (Tfloat F64 noattr) Tnil)
      (Tlong Signed noattr).

  Instance sextcall_longoffloat_properties:
    ExtcallProperties sextcall_longoffloat_info.
  Proof.
    constructor; try (inversion 1; congruence).
    * (* type *)
      inversion 1; subst.
      destruct x; try discriminate.
      simpl in Hxz.
      destruct (Float.longoffloat f); try discriminate.
      inv Hxz.
      constructor.
    * (* unchanged_on loc_not_writable *)
      inversion 1; subst. apply Mem.unchanged_on_refl.
    * (* extends *)
      inversion 1; subst.
      generalize Hxz.
      intro Hy.
      destruct x; try discriminate.
      simpl in Hxz.
      destruct (Float.longoffloat f); try discriminate.
      inv Hxz.
      inversion 2; subst. inv H6.
      inv H4.
      esplit. esplit. split.
      econstructor; eauto.
      split; auto.
      split; auto.
      apply Mem.unchanged_on_refl.
    * (* injects *)
      inversion 2; subst.
      generalize Hxz.
      intro Hy.
      destruct x; try discriminate.
      simpl in Hxz.
      destruct (Float.longoffloat f0); try discriminate.
      inv Hxz.
      inversion 2; subst.
      inv H5. inv H7.
      intros.
      esplit. esplit. esplit. split.
      econstructor; eauto.
      split. econstructor.
      split. eassumption.
      split. apply Mem.unchanged_on_refl.
      split. apply Mem.unchanged_on_refl.
      split. apply inject_incr_refl.
      intro. congruence.
    * (* determ *)
      inversion 1; inversion 1; split; congruence.
    * (* WB weak *)
      inversion 2; subst; econstructor; eauto.
  Qed.

  Instance sextcall_longoffloat_invariants:
    ExtcallInvariants sextcall_longoffloat_info.
  Proof.
    constructor; inversion 1; try congruence; try reflexivity.
    * (* inject neutral *)
      subst.
      split; auto.
      destruct x; try discriminate.
      simpl in Hxz.
      destruct (Float.longoffloat f); try discriminate.
      inv Hxz. constructor.
    * (* type *)
      subst.
      destruct x; try discriminate.
      simpl in Hxz.
      destruct (Float.longoffloat f); try discriminate.
      inv Hxz.
      constructor.
  Qed.

  Definition sextcall_longoffloat_primsem: sextcall_primsem D :=
    csem_full sextcall_longoffloat_info.

  Definition sextcall_longoffloat_compatsem: compatsem D :=
    inl sextcall_longoffloat_primsem.

  (** longuoffloat *)

  Inductive sextcall_longuoffloat_step (s: stencil) (WB: block -> Prop):
    list val -> mwd D -> val -> mwd D -> Prop :=
  | sextcall_longuoffloat_step_intro
      x z
      (Hxz: Val.longuoffloat x = Some z)
      m :
      sextcall_longuoffloat_step s WB (x :: nil) m z m
  .

  Definition sextcall_longuoffloat_info :=
    csem_info
      sextcall_longuoffloat_step
      (Tcons (Tfloat F64 noattr) Tnil)
      (Tlong Unsigned noattr).

  Instance sextcall_longuoffloat_properties:
    ExtcallProperties sextcall_longuoffloat_info.
  Proof.
    constructor; try (inversion 1; congruence).
    * (* type *)
      inversion 1; subst.
      destruct x; try discriminate.
      simpl in Hxz.
      destruct (Float.longuoffloat f); try discriminate.
      inv Hxz.
      constructor.
    * (* unchanged_on loc_not_writable *)
      inversion 1; subst. apply Mem.unchanged_on_refl.
    * (* extends *)
      inversion 1; subst.
      generalize Hxz.
      intro Hy.
      destruct x; try discriminate.
      simpl in Hxz.
      destruct (Float.longuoffloat f); try discriminate.
      inv Hxz.
      inversion 2; subst. inv H6.
      inv H4.
      esplit. esplit. split.
      econstructor; eauto.
      split; auto.
      split; auto.
      apply Mem.unchanged_on_refl.
    * (* injects *)
      inversion 2; subst.
      generalize Hxz.
      intro Hy.
      destruct x; try discriminate.
      simpl in Hxz.
      destruct (Float.longuoffloat f0); try discriminate.
      inv Hxz.
      inversion 2; subst.
      inv H5. inv H7.
      intros.
      esplit. esplit. esplit. split.
      econstructor; eauto.
      split. econstructor.
      split. eassumption.
      split. apply Mem.unchanged_on_refl.
      split. apply Mem.unchanged_on_refl.
      split. apply inject_incr_refl.
      intro. congruence.
    * (* determ *)
      inversion 1; inversion 1; split; congruence.
    * (* WB weak *)
      inversion 2; subst; econstructor; eauto.
  Qed.

  Instance sextcall_longuoffloat_invariants:
    ExtcallInvariants sextcall_longuoffloat_info.
  Proof.
    constructor; inversion 1; try congruence; try reflexivity.
    * (* inject neutral *)
      subst.
      split; auto.
      destruct x; try discriminate.
      simpl in Hxz.
      destruct (Float.longuoffloat f); try discriminate.
      inv Hxz. constructor.
    * (* type *)
      subst.
      destruct x; try discriminate.
      simpl in Hxz.
      destruct (Float.longuoffloat f); try discriminate.
      inv Hxz.
      constructor.
  Qed.

  Definition sextcall_longuoffloat_primsem: sextcall_primsem D :=
    csem_full sextcall_longuoffloat_info.

  Definition sextcall_longuoffloat_compatsem: compatsem D :=
    inl sextcall_longuoffloat_primsem.

  (** floatoflong *)

  Inductive sextcall_floatoflong_step (s: stencil) (WB: block -> Prop):
    list val -> mwd D -> val -> mwd D -> Prop :=
  | sextcall_floatoflong_step_intro
      x z
      (Hxz: Val.floatoflong x = Some z)
      m :
      sextcall_floatoflong_step s WB (x :: nil) m z m
  .

  Definition sextcall_floatoflong_info :=
    csem_info
      sextcall_floatoflong_step
      (Tcons (Tlong Signed noattr) Tnil)
      (Tfloat F64 noattr).

  Instance sextcall_floatoflong_properties:
    ExtcallProperties sextcall_floatoflong_info.
  Proof.
    constructor; try (inversion 1; congruence).
    * (* type *)
      inversion 1; subst.
      destruct x; try discriminate.
      simpl in Hxz.
      inv Hxz.
      constructor.
    * (* unchanged_on loc_not_writable *)
      inversion 1; subst. apply Mem.unchanged_on_refl.
    * (* extends *)
      inversion 1; subst.
      generalize Hxz.
      intro Hy.
      destruct x; try discriminate.
      simpl in Hxz.
      inv Hxz.
      inversion 2; subst. inv H6.
      inv H4.
      esplit. esplit. split.
      econstructor; eauto.
      split; auto.
      split; auto.
      apply Mem.unchanged_on_refl.
    * (* injects *)
      inversion 2; subst.
      generalize Hxz.
      intro Hy.
      destruct x; try discriminate.
      simpl in Hxz.
      inv Hxz.
      inversion 2; subst.
      inv H5. inv H7.
      intros.
      esplit. esplit. esplit. split.
      econstructor; eauto.
      split. econstructor.
      split. eassumption.
      split. apply Mem.unchanged_on_refl.
      split. apply Mem.unchanged_on_refl.
      split. apply inject_incr_refl.
      intro. congruence.
    * (* determ *)
      inversion 1; inversion 1; split; congruence.
    * (* WB weak *)
      inversion 2; subst; econstructor; eauto.
  Qed.

  Instance sextcall_floatoflong_invariants:
    ExtcallInvariants sextcall_floatoflong_info.
  Proof.
    constructor; inversion 1; try congruence; try xomega.
    * (* inject neutral *)
      subst.
      split; auto.
      destruct x; try discriminate.
      simpl in Hxz.
      inv Hxz. constructor.
    * (* type *)
      subst.
      destruct x; try discriminate.
      simpl in Hxz.
      inv Hxz.
      constructor.
  Qed.

  Definition sextcall_floatoflong_primsem: sextcall_primsem D :=
    csem_full sextcall_floatoflong_info.

  Definition sextcall_floatoflong_compatsem: compatsem D :=
    inl sextcall_floatoflong_primsem.

  (** floatoflongu *)

  Inductive sextcall_floatoflongu_step (s: stencil) (WB: block -> Prop):
    list val -> mwd D -> val -> mwd D -> Prop :=
  | sextcall_floatoflongu_step_intro
      x z
      (Hxz: Val.floatoflongu x = Some z)
      m :
      sextcall_floatoflongu_step s WB (x :: nil) m z m
  .

  Definition sextcall_floatoflongu_info :=
    csem_info
      sextcall_floatoflongu_step
      (Tcons (Tlong Unsigned noattr) Tnil)
      (Tfloat F64 noattr).

  Instance sextcall_floatoflongu_properties:
    ExtcallProperties sextcall_floatoflongu_info.
  Proof.
    constructor; try (inversion 1; congruence).
    * (* type *)
      inversion 1; subst.
      destruct x; try discriminate.
      simpl in Hxz.
      inv Hxz.
      constructor.
    * (* unchanged_on loc_not_writable *)
      inversion 1; subst. apply Mem.unchanged_on_refl.
    * (* extends *)
      inversion 1; subst.
      generalize Hxz.
      intro Hy.
      destruct x; try discriminate.
      simpl in Hxz.
      inv Hxz.
      inversion 2; subst. inv H6.
      inv H4.
      esplit. esplit. split.
      econstructor; eauto.
      split; auto.
      split; auto.
      apply Mem.unchanged_on_refl.
    * (* injects *)
      inversion 2; subst.
      generalize Hxz.
      intro Hy.
      destruct x; try discriminate.
      simpl in Hxz.
      inv Hxz.
      inversion 2; subst.
      inv H5. inv H7.
      intros.
      esplit. esplit. esplit. split.
      econstructor; eauto.
      split. econstructor.
      split. eassumption.
      split. apply Mem.unchanged_on_refl.
      split. apply Mem.unchanged_on_refl.
      split. apply inject_incr_refl.
      intro. congruence.
    * (* determ *)
      inversion 1; inversion 1; split; congruence.
    * (* WB weak *)
      inversion 2; subst; econstructor; eauto.
  Qed.

  Instance sextcall_floatoflongu_invariants:
    ExtcallInvariants sextcall_floatoflongu_info.
  Proof.
    constructor; inversion 1; try congruence; try xomega.
    * (* inject neutral *)
      inversion 1; subst.
      split; auto.
      destruct x; try discriminate.
      simpl in Hxz.
      inv Hxz. constructor.
    * (* type *)
      subst.
      destruct x; try discriminate.
      simpl in Hxz.
      inv Hxz.
      constructor.
  Qed.

  Definition sextcall_floatoflongu_primsem: sextcall_primsem D :=
    csem_full sextcall_floatoflongu_info.

  Definition sextcall_floatoflongu_compatsem: compatsem D :=
    inl sextcall_floatoflongu_primsem.

  (** singleoflong *)

  Inductive sextcall_singleoflong_step (s: stencil) (WB: block -> Prop):
    list val -> mwd D -> val -> mwd D -> Prop :=
  | sextcall_singleoflong_step_intro
      x z
      (Hxz: Val.singleoflong x = Some z)
      m :
      sextcall_singleoflong_step s WB (x :: nil) m z m
  .

  Definition sextcall_singleoflong_info :=
    csem_info
      sextcall_singleoflong_step
      (Tcons (Tlong Signed noattr) Tnil)
      (Tfloat F32 noattr).

  Instance sextcall_singleoflong_properties:
    ExtcallProperties sextcall_singleoflong_info.
  Proof.
    constructor; try (inversion 1; congruence).
    * (* type *)
      inversion 1; subst.
      destruct x; try discriminate.
      simpl in Hxz.
      inv Hxz.
      simpl. rewrite <- Float.singleoflong_idem. apply Float.singleoffloat_is_single.
    * (* unchanged_on loc_not_writable *)
      inversion 1; subst. apply Mem.unchanged_on_refl.
    * (* extends *)
      inversion 1; subst.
      generalize Hxz.
      intro Hy.
      destruct x; try discriminate.
      simpl in Hxz.
      inv Hxz.
      inversion 2; subst. inv H6.
      inv H4.
      esplit. esplit. split.
      econstructor; eauto.
      split; auto.
      split; auto.
      apply Mem.unchanged_on_refl.
    * (* injects *)
      inversion 2; subst.
      generalize Hxz.
      intro Hy.
      destruct x; try discriminate.
      simpl in Hxz.
      inv Hxz.
      inversion 2; subst.
      inv H5. inv H7.
      intros.
      esplit. esplit. esplit. split.
      econstructor; eauto.
      split. econstructor.
      split. eassumption.
      split. apply Mem.unchanged_on_refl.
      split. apply Mem.unchanged_on_refl.
      split. apply inject_incr_refl.
      intro. congruence.
    * (* determ *)
      inversion 1; inversion 1; split; congruence.
    * (* WB weak *)
      inversion 2; subst; econstructor; eauto.
  Qed.

  Instance sextcall_singleoflong_invariants:
    ExtcallInvariants sextcall_singleoflong_info.
  Proof.
    constructor; inversion 1; try congruence; try xomega.
    * (* inject neutral *)
      inversion 1; subst.
      split; auto.
      destruct x; try discriminate.
      simpl in Hxz.
      inv Hxz. constructor.
    * (* type *)
      subst.
      destruct x; try discriminate.
      simpl in Hxz.
      inv Hxz.
      simpl. rewrite <- Float.singleoflong_idem. apply Float.singleoffloat_is_single.
  Qed.

  Definition sextcall_singleoflong_primsem: sextcall_primsem D :=
    csem_full sextcall_singleoflong_info.

  Definition sextcall_singleoflong_compatsem: compatsem D :=
    inl sextcall_singleoflong_primsem.

  (** singleoflongu *)

  Inductive sextcall_singleoflongu_step (s: stencil) (WB: block -> Prop):
    list val -> mwd D -> val -> mwd D -> Prop :=
  | sextcall_singleoflongu_step_intro
      x z
      (Hxz: Val.singleoflongu x = Some z)
      m :
      sextcall_singleoflongu_step s WB (x :: nil) m z m
  .

  Definition sextcall_singleoflongu_info :=
    csem_info
      sextcall_singleoflongu_step
      (Tcons (Tlong Unsigned noattr) Tnil)
      (Tfloat F32 noattr).

  Instance sextcall_singleoflongu_properties:
    ExtcallProperties sextcall_singleoflongu_info.
  Proof.
    constructor; try (inversion 1; congruence).
    * (* type *)
      inversion 1; subst.
      destruct x; try discriminate.
      simpl in Hxz.
      inv Hxz.
      simpl.
      unfold Float.singleoflongu.
      esplit. reflexivity.
    * (* unchanged_on loc_not_writable *)
      inversion 1; subst. apply Mem.unchanged_on_refl.
    * (* extends *)
      inversion 1; subst.
      generalize Hxz.
      intro Hy.
      destruct x; try discriminate.
      simpl in Hxz.
      inv Hxz.
      inversion 2; subst. inv H6.
      inv H4.
      esplit. esplit. split.
      econstructor; eauto.
      split; auto.
      split; auto.
      apply Mem.unchanged_on_refl.
    * (* injects *)
      inversion 2; subst.
      generalize Hxz.
      intro Hy.
      destruct x; try discriminate.
      simpl in Hxz.
      inv Hxz.
      inversion 2; subst.
      inv H5. inv H7.
      intros.
      esplit. esplit. esplit. split.
      econstructor; eauto.
      split. econstructor.
      split. eassumption.
      split. apply Mem.unchanged_on_refl.
      split. apply Mem.unchanged_on_refl.
      split. apply inject_incr_refl.
      intro. congruence.
    * (* determ *)
      inversion 1; inversion 1; split; congruence.
    * (* WB weak *)
      inversion 2; subst; econstructor; eauto.
  Qed.

  Instance sextcall_singleoflongu_invariants:
    ExtcallInvariants sextcall_singleoflongu_info.
  Proof.
    constructor; inversion 1; try congruence; try xomega.
    * (* inject neutral *)
      subst.
      split; auto.
      destruct x; try discriminate.
      simpl in Hxz.
      inv Hxz. constructor.
    * (* type *)
      subst.
      destruct x; try discriminate.
      simpl in Hxz.
      inv Hxz.
      simpl.
      unfold Float.singleoflongu.
      esplit. reflexivity.
  Qed.

  Definition sextcall_singleoflongu_primsem: sextcall_primsem D :=
    csem_full sextcall_singleoflongu_info.

  Definition sextcall_singleoflongu_compatsem: compatsem D :=
    inl sextcall_singleoflongu_primsem.

  (** divls *)

  Inductive sextcall_divls_step (s: stencil) (WB: block -> Prop):
    list val -> mwd D -> val -> mwd D -> Prop :=
  | sextcall_divls_step_intro
      x y z
      (Hxz: Val.divls x y = Some z)
      m :
      sextcall_divls_step s WB (x :: y :: nil) m z m
  .

  Definition sextcall_divls_info :=
    csem_info
      sextcall_divls_step
      (Tcons (Tlong Signed noattr) (Tcons (Tlong Signed noattr) Tnil))
      (Tlong Signed noattr).

  Instance sextcall_divls_properties:
    ExtcallProperties sextcall_divls_info.
  Proof.
    constructor; try (inversion 1; congruence).
    * (* type *)
      inversion 1; subst.
      destruct x; try discriminate.
      destruct y; try discriminate.
      simpl in Hxz.
      destruct (
          Int64.eq i0 Int64.zero
            || Int64.eq i (Int64.repr Int64.min_signed) &&
               Int64.eq i0 Int64.mone
        ); try discriminate.
      inv Hxz.
      constructor.
    * (* unchanged_on loc_not_writable *)
      inversion 1; subst. apply Mem.unchanged_on_refl.
    * (* extends *)
      inversion 1; subst.
      generalize Hxz.
      intro Hy.
      destruct x; try discriminate.
      destruct y; try discriminate.
      simpl in Hxz.
      destruct (
          Int64.eq i0 Int64.zero
            || Int64.eq i (Int64.repr Int64.min_signed) &&
               Int64.eq i0 Int64.mone
        ); try discriminate.
      inv Hxz.
      inversion 2; subst. inv H6.
      inv H4. inv H5. inv H8.
      esplit. esplit. split.
      econstructor; eauto.
      split; auto.
      split; auto.
      apply Mem.unchanged_on_refl.
    * (* injects *)
      inversion 2; subst.
      generalize Hxz.
      intro Hy.
      destruct x; try discriminate.
      destruct y; try discriminate.
      simpl in Hxz.
      destruct (
          Int64.eq i0 Int64.zero
            || Int64.eq i (Int64.repr Int64.min_signed) &&
               Int64.eq i0 Int64.mone
        ); try discriminate.
      inv Hxz.
      inversion 2; subst.
      inv H5. inv H7.
      inv H5. inv H8.
      intros.
      esplit. esplit. esplit. split.
      econstructor; eauto.
      split. econstructor.
      split. eassumption.
      split. apply Mem.unchanged_on_refl.
      split. apply Mem.unchanged_on_refl.
      split. apply inject_incr_refl.
      intro. congruence.
    * (* determ *)
      inversion 1; inversion 1; split; congruence.
    * (* WB weak *)
      inversion 2; subst; econstructor; eauto.
  Qed.

  Instance sextcall_divls_invariants:
    ExtcallInvariants sextcall_divls_info.
  Proof.
    constructor; inversion 1; try congruence; try xomega.
    * (* inject neutral *)
      inversion 1; subst.
      split; auto.
      destruct x; try discriminate.
      simpl in Hxz.
      destruct y; try discriminate.
      destruct (
          Int64.eq i0 Int64.zero
            || Int64.eq i (Int64.repr Int64.min_signed) &&
               Int64.eq i0 Int64.mone
        ); try discriminate.
      inv Hxz. constructor.
    * (* type *)
      subst.
      destruct x; try discriminate.
      destruct y; try discriminate.
      simpl in Hxz.
      destruct (
          Int64.eq i0 Int64.zero
            || Int64.eq i (Int64.repr Int64.min_signed) &&
               Int64.eq i0 Int64.mone
        ); try discriminate.
      inv Hxz.
      constructor.
  Qed.

  Definition sextcall_divls_primsem: sextcall_primsem D :=
    csem_full sextcall_divls_info.

  Definition sextcall_divls_compatsem: compatsem D :=
    inl sextcall_divls_primsem.

  (** divlu *)

  Inductive sextcall_divlu_step (s: stencil) (WB: block -> Prop):
    list val -> mwd D -> val -> mwd D -> Prop :=
  | sextcall_divlu_step_intro
      x y z
      (Hxz: Val.divlu x y = Some z)
      m :
      sextcall_divlu_step s WB (x :: y :: nil) m z m
  .

  Definition sextcall_divlu_info :=
    csem_info
      sextcall_divlu_step
      (Tcons (Tlong Unsigned noattr) (Tcons (Tlong Unsigned noattr) Tnil))
      (Tlong Unsigned noattr).

  Instance sextcall_divlu_properties:
    ExtcallProperties sextcall_divlu_info.
  Proof.
    constructor; try (inversion 1; congruence).
    * (* type *)
      inversion 1; subst.
      destruct x; try discriminate.
      destruct y; try discriminate.
      simpl in Hxz.
      destruct (Int64.eq i0 Int64.zero); try discriminate.
      inv Hxz.
      constructor.
    * (* unchanged_on loc_not_writable *)
      inversion 1; subst. apply Mem.unchanged_on_refl.
    * (* extends *)
      inversion 1; subst.
      generalize Hxz.
      intro Hy.
      destruct x; try discriminate.
      destruct y; try discriminate.
      simpl in Hxz.
      destruct (Int64.eq i0 Int64.zero); try discriminate.
      inv Hxz.
      inversion 2; subst. inv H6.
      inv H4. inv H5. inv H8.
      esplit. esplit. split.
      econstructor; eauto.
      split; auto.
      split; auto.
      apply Mem.unchanged_on_refl.
    * (* injects *)
      inversion 2; subst.
      generalize Hxz.
      intro Hy.
      destruct x; try discriminate.
      destruct y; try discriminate.
      simpl in Hxz.
      destruct (Int64.eq i0 Int64.zero); try discriminate.
      inv Hxz.
      inversion 2; subst.
      inv H5. inv H7.
      inv H5. inv H8.
      intros.
      esplit. esplit. esplit. split.
      econstructor; eauto.
      split. econstructor.
      split. eassumption.
      split. apply Mem.unchanged_on_refl.
      split. apply Mem.unchanged_on_refl.
      split. apply inject_incr_refl.
      intro. congruence.
    * (* determ *)
      inversion 1; inversion 1; split; congruence.
    * (* WB weak *)
      inversion 2; subst; econstructor; eauto.
  Qed.

  Instance sextcall_divlu_invariants:
    ExtcallInvariants sextcall_divlu_info.
  Proof.
    constructor; inversion 1; try congruence; try xomega.
    * (* inject neutral *)
      inversion 1; subst.
      split; auto.
      destruct x; try discriminate.
      simpl in Hxz.
      destruct y; try discriminate.
      destruct (Int64.eq i0 Int64.zero); try discriminate.
      inv Hxz. constructor.
    * (* type *)
      subst.
      destruct x; try discriminate.
      destruct y; try discriminate.
      simpl in Hxz.
      destruct (Int64.eq i0 Int64.zero); try discriminate.
      inv Hxz.
      constructor.
  Qed.

  Definition sextcall_divlu_primsem: sextcall_primsem D :=
    csem_full sextcall_divlu_info.

  Definition sextcall_divlu_compatsem: compatsem D :=
    inl sextcall_divlu_primsem.

  (** modls *)

  Inductive sextcall_modls_step (s: stencil) (WB: block -> Prop):
    list val -> mwd D -> val -> mwd D -> Prop :=
  | sextcall_modls_step_intro
      x y z
      (Hxz: Val.modls x y = Some z)
      m :
      sextcall_modls_step s WB (x :: y :: nil) m z m
  .

  Definition sextcall_modls_info :=
    csem_info
      sextcall_modls_step
      (Tcons (Tlong Signed noattr) (Tcons (Tlong Signed noattr) Tnil))
      (Tlong Signed noattr).

  Instance sextcall_modls_properties:
    ExtcallProperties sextcall_modls_info.
  Proof.
    constructor; try (inversion 1; congruence).
    * (* type *)
      inversion 1; subst.
      destruct x; try discriminate.
      destruct y; try discriminate.
      simpl in Hxz.
      destruct (
          Int64.eq i0 Int64.zero
            || Int64.eq i (Int64.repr Int64.min_signed) &&
               Int64.eq i0 Int64.mone
        ); try discriminate.
      inv Hxz.
      constructor.
    * (* unchanged_on loc_not_writable *)
      inversion 1; subst. apply Mem.unchanged_on_refl.
    * (* extends *)
      inversion 1; subst.
      generalize Hxz.
      intro Hy.
      destruct x; try discriminate.
      destruct y; try discriminate.
      simpl in Hxz.
      destruct (
          Int64.eq i0 Int64.zero
            || Int64.eq i (Int64.repr Int64.min_signed) &&
               Int64.eq i0 Int64.mone
        ); try discriminate.
      inv Hxz.
      inversion 2; subst. inv H6.
      inv H4. inv H5. inv H8.
      esplit. esplit. split.
      econstructor; eauto.
      split; auto.
      split; auto.
      apply Mem.unchanged_on_refl.
    * (* injects *)
      inversion 2; subst.
      generalize Hxz.
      intro Hy.
      destruct x; try discriminate.
      destruct y; try discriminate.
      simpl in Hxz.
      destruct (
          Int64.eq i0 Int64.zero
            || Int64.eq i (Int64.repr Int64.min_signed) &&
               Int64.eq i0 Int64.mone
        ); try discriminate.
      inv Hxz.
      inversion 2; subst.
      inv H5. inv H7.
      inv H5. inv H8.
      intros.
      esplit. esplit. esplit. split.
      econstructor; eauto.
      split. econstructor.
      split. eassumption.
      split. apply Mem.unchanged_on_refl.
      split. apply Mem.unchanged_on_refl.
      split. apply inject_incr_refl.
      intro. congruence.
    * (* determ *)
      inversion 1; inversion 1; split; congruence.
    * (* WB weak *)
      inversion 2; subst; econstructor; eauto.
  Qed.

  Instance sextcall_modls_invariants:
    ExtcallInvariants sextcall_modls_info.
  Proof.
    constructor; inversion 1; try congruence; try xomega.
    * (* inject neutral *)
      inversion 1; subst.
      split; auto.
      destruct x; try discriminate.
      simpl in Hxz.
      destruct y; try discriminate.
      destruct (
          Int64.eq i0 Int64.zero
            || Int64.eq i (Int64.repr Int64.min_signed) &&
               Int64.eq i0 Int64.mone
        ); try discriminate.
      inv Hxz. constructor.
    * (* type *)
      subst.
      destruct x; try discriminate.
      destruct y; try discriminate.
      simpl in Hxz.
      destruct (
          Int64.eq i0 Int64.zero
            || Int64.eq i (Int64.repr Int64.min_signed) &&
               Int64.eq i0 Int64.mone
        ); try discriminate.
      inv Hxz.
      constructor.
  Qed.

  Definition sextcall_modls_primsem: sextcall_primsem D :=
    csem_full sextcall_modls_info.

  Definition sextcall_modls_compatsem: compatsem D :=
    inl sextcall_modls_primsem.

  (** modlu *)

  Inductive sextcall_modlu_step (s: stencil) (WB: block -> Prop):
    list val -> mwd D -> val -> mwd D -> Prop :=
  | sextcall_modlu_step_intro
      x y z
      (Hxz: Val.modlu x y = Some z)
      m :
      sextcall_modlu_step s WB (x :: y :: nil) m z m
  .

  Definition sextcall_modlu_info :=
    csem_info
      sextcall_modlu_step
      (Tcons (Tlong Unsigned noattr) (Tcons (Tlong Unsigned noattr) Tnil))
      (Tlong Unsigned noattr).

  Instance sextcall_modlu_properties:
    ExtcallProperties sextcall_modlu_info.
  Proof.
    constructor; try (inversion 1; congruence).
    * (* type *)
      inversion 1; subst.
      destruct x; try discriminate.
      destruct y; try discriminate.
      simpl in Hxz.
      destruct (Int64.eq i0 Int64.zero); try discriminate.
      inv Hxz.
      constructor.
    * (* unchanged_on loc_not_writable *)
      inversion 1; subst. apply Mem.unchanged_on_refl.
    * (* extends *)
      inversion 1; subst.
      generalize Hxz.
      intro Hy.
      destruct x; try discriminate.
      destruct y; try discriminate.
      simpl in Hxz.
      destruct (Int64.eq i0 Int64.zero); try discriminate.
      inv Hxz.
      inversion 2; subst. inv H6.
      inv H4. inv H5. inv H8.
      esplit. esplit. split.
      econstructor; eauto.
      split; auto.
      split; auto.
      apply Mem.unchanged_on_refl.
    * (* injects *)
      inversion 2; subst.
      generalize Hxz.
      intro Hy.
      destruct x; try discriminate.
      destruct y; try discriminate.
      simpl in Hxz.
      destruct (Int64.eq i0 Int64.zero); try discriminate.
      inv Hxz.
      inversion 2; subst.
      inv H5. inv H7.
      inv H5. inv H8.
      intros.
      esplit. esplit. esplit. split.
      econstructor; eauto.
      split. econstructor.
      split. eassumption.
      split. apply Mem.unchanged_on_refl.
      split. apply Mem.unchanged_on_refl.
      split. apply inject_incr_refl.
      intro. congruence.
    * (* determ *)
      inversion 1; inversion 1; split; congruence.
    * (* WB weak *)
      inversion 2; subst; econstructor; eauto.
  Qed.

  Instance sextcall_modlu_invariants:
    ExtcallInvariants sextcall_modlu_info.
  Proof.
    constructor; inversion 1; try congruence; try xomega.
    * (* inject neutral *)
      inversion 1; subst.
      split; auto.
      destruct x; try discriminate.
      simpl in Hxz.
      destruct y; try discriminate.
      destruct (Int64.eq i0 Int64.zero); try discriminate.
      inv Hxz. constructor.
    * (* type *)
      subst.
      destruct x; try discriminate.
      destruct y; try discriminate.
      simpl in Hxz.
      destruct (Int64.eq i0 Int64.zero); try discriminate.
      inv Hxz.
      constructor.
  Qed.

  Definition sextcall_modlu_primsem: sextcall_primsem D :=
    csem_full sextcall_modlu_info.

  Definition sextcall_modlu_compatsem: compatsem D :=
    inl sextcall_modlu_primsem.

  (** shll *)

  Inductive sextcall_shll_step (s: stencil) (WB: block -> Prop):
    list val -> mwd D -> val -> mwd D -> Prop :=
  | sextcall_shll_step_intro
      x y z
      (Hxz: Val.shll x y = z)
      m :
      sextcall_shll_step s WB (x :: y :: nil) m z m
  .

  Definition sextcall_shll_info :=
    csem_info
      sextcall_shll_step
      (Tcons (Tlong Signed noattr) (Tcons (Tint I32 Unsigned noattr) Tnil))
      (Tlong Signed noattr).

  Instance sextcall_shll_properties:
    ExtcallProperties sextcall_shll_info.
  Proof.
    constructor; try (inversion 1; congruence).
    * (* type *)
      inversion 1; subst.
      destruct x; simpl; auto.
      destruct y; simpl; auto.
      destruct (Int.ltu i0 Int64.iwordsize'); simpl; auto.
    * (* unchanged_on loc_not_writable *)
      inversion 1; subst. apply Mem.unchanged_on_refl.
    * (* extends *)
      inversion 1; subst.
      inversion 2; subst. inv H6. inv H8.
      esplit. esplit. split.
      econstructor. reflexivity.
      split.
      inv H4; simpl; auto.
      destruct v2; simpl; auto.
      inv H5; simpl; auto.
      split; auto.
      apply Mem.unchanged_on_refl.
    * (* injects *)
      inversion 2; subst.
      inversion 2; subst.
      inv H7. inv H9.
      esplit. esplit. esplit.
      split. econstructor. reflexivity.
      instantiate (1 := f).
      split.
       inv H5; simpl; auto.
       inv H6; simpl; auto.
       destruct (Int.ltu i0 Int64.iwordsize'); auto.
      split. eassumption.
      split. apply Mem.unchanged_on_refl.
      split. apply Mem.unchanged_on_refl.
      split. apply inject_incr_refl.
      intro. congruence.
    * (* determ *)
      inversion 1; inversion 1; split; congruence.
    * (* WB weak *)
      inversion 2; subst; econstructor; eauto.
  Qed.

  Instance sextcall_shll_invariants:
    ExtcallInvariants sextcall_shll_info.
  Proof.
    constructor; inversion 1; try congruence; try xomega.
    * (* inject neutral *)
      inversion 1; subst.
      split; auto.
      destruct x; simpl; try (constructor; fail).
      destruct y; simpl; try (constructor; fail).
      destruct (Int.ltu i0 Int64.iwordsize'); constructor.
    * (* type *)
      subst.
      destruct x; simpl; auto.
      destruct y; simpl; auto.
      destruct (Int.ltu i0 Int64.iwordsize'); simpl; auto.
  Qed.

  Definition sextcall_shll_primsem: sextcall_primsem D :=
    csem_full sextcall_shll_info.

  Definition sextcall_shll_compatsem: compatsem D :=
    inl sextcall_shll_primsem.

  (** shrlu *)

  Inductive sextcall_shrlu_step (s: stencil) (WB: block -> Prop):
    list val -> mwd D -> val -> mwd D -> Prop :=
  | sextcall_shrlu_step_intro
      x y z
      (Hxz: Val.shrlu x y = z)
      m :
      sextcall_shrlu_step s WB (x :: y :: nil) m z m
  .

  Definition sextcall_shrlu_info :=
    csem_info
      sextcall_shrlu_step
      (Tcons (Tlong Unsigned noattr) (Tcons (Tint I32 Unsigned noattr) Tnil))
      (Tlong Signed noattr).

  Instance sextcall_shrlu_properties:
    ExtcallProperties sextcall_shrlu_info.
  Proof.
    constructor; try (inversion 1; congruence).
    * (* type *)
      inversion 1; subst.
      destruct x; simpl; auto.
      destruct y; simpl; auto.
      destruct (Int.ltu i0 Int64.iwordsize'); simpl; auto.
    * (* unchanged_on loc_not_writable *)
      inversion 1; subst. apply Mem.unchanged_on_refl.
    * (* extends *)
      inversion 1; subst.
      inversion 2; subst. inv H6. inv H8.
      esplit. esplit. split.
      econstructor. reflexivity.
      split.
      inv H4; simpl; auto.
      destruct v2; simpl; auto.
      inv H5; simpl; auto.
      split; auto.
      apply Mem.unchanged_on_refl.
    * (* injects *)
      inversion 2; subst.
      inversion 2; subst.
      inv H7. inv H9.
      esplit. esplit. esplit.
      split. econstructor. reflexivity.
      instantiate (1 := f).
      split.
       inv H5; simpl; auto.
       inv H6; simpl; auto.
       destruct (Int.ltu i0 Int64.iwordsize'); auto.
      split. eassumption.
      split. apply Mem.unchanged_on_refl.
      split. apply Mem.unchanged_on_refl.
      split. apply inject_incr_refl.
      intro. congruence.
    * (* determ *)
      inversion 1; inversion 1; split; congruence.
    * (* WB weak *)
      inversion 2; subst; econstructor; eauto.
  Qed.

  Instance sextcall_shrlu_invariants:
    ExtcallInvariants sextcall_shrlu_info.
  Proof.
    constructor; inversion 1; try congruence; try xomega.
    * (* inject neutral *)
      inversion 1; subst.
      split; auto.
      destruct x; simpl; try (constructor; fail).
      destruct y; simpl; try (constructor; fail).
      destruct (Int.ltu i0 Int64.iwordsize'); constructor.
    * (* type *)
      subst.
      destruct x; simpl; auto.
      destruct y; simpl; auto.
      destruct (Int.ltu i0 Int64.iwordsize'); simpl; auto.
  Qed.

  Definition sextcall_shrlu_primsem: sextcall_primsem D :=
    csem_full sextcall_shrlu_info.

  Definition sextcall_shrlu_compatsem: compatsem D :=
    inl sextcall_shrlu_primsem.

  (** shrl *)

  Inductive sextcall_shrl_step (s: stencil) (WB: block -> Prop):
    list val -> mwd D -> val -> mwd D -> Prop :=
  | sextcall_shrl_step_intro
      x y z
      (Hxz: Val.shrl x y = z)
      m :
      sextcall_shrl_step s WB (x :: y :: nil) m z m
  .

  Definition sextcall_shrl_info :=
    csem_info
      sextcall_shrl_step
      (Tcons (Tlong Signed noattr) (Tcons (Tint I32 Unsigned noattr) Tnil))
      (Tlong Signed noattr).

  Instance sextcall_shrl_properties:
    ExtcallProperties sextcall_shrl_info.
  Proof.
    constructor; try (inversion 1; congruence).
    * (* type *)
      inversion 1; subst.
      destruct x; simpl; auto.
      destruct y; simpl; auto.
      destruct (Int.ltu i0 Int64.iwordsize'); simpl; auto.
    * (* unchanged_on loc_not_writable *)
      inversion 1; subst. apply Mem.unchanged_on_refl.
    * (* extends *)
      inversion 1; subst.
      inversion 2; subst. inv H6. inv H8.
      esplit. esplit. split.
      econstructor. reflexivity.
      split.
      inv H4; simpl; auto.
      destruct v2; simpl; auto.
      inv H5; simpl; auto.
      split; auto.
      apply Mem.unchanged_on_refl.
    * (* injects *)
      inversion 2; subst.
      inversion 2; subst.
      inv H7. inv H9.
      esplit. esplit. esplit.
      split. econstructor. reflexivity.
      instantiate (1 := f).
      split.
       inv H5; simpl; auto.
       inv H6; simpl; auto.
       destruct (Int.ltu i0 Int64.iwordsize'); auto.
      split. eassumption.
      split. apply Mem.unchanged_on_refl.
      split. apply Mem.unchanged_on_refl.
      split. apply inject_incr_refl.
      intro. congruence.
    * (* determ *)
      inversion 1; inversion 1; split; congruence.
    * (* WB weak *)
      inversion 2; subst; econstructor; eauto.
  Qed.

  Instance sextcall_shrl_invariants:
    ExtcallInvariants sextcall_shrl_info.
  Proof.
    constructor; inversion 1; try congruence; try xomega.
    * (* inject neutral *)
      inversion 1; subst.
      split; auto.
      destruct x; simpl; try (constructor; fail).
      destruct y; simpl; try (constructor; fail).
      destruct (Int.ltu i0 Int64.iwordsize'); constructor.
    * (* type *)
      subst.
      destruct x; simpl; auto.
      destruct y; simpl; auto.
      destruct (Int.ltu i0 Int64.iwordsize'); simpl; auto.
  Qed.

  Definition sextcall_shrl_primsem: sextcall_primsem D :=
    csem_full sextcall_shrl_info.

  Definition sextcall_shrl_compatsem: compatsem D :=
    inl sextcall_shrl_primsem.

  (** Pack everything in a single layer *)

  Definition L64: compatlayer D :=
    ((i64_dtos hf) ↦ sextcall_longoffloat_compatsem)
      ⊕ ((i64_dtou hf) ↦ sextcall_longuoffloat_compatsem)
      ⊕ ((i64_stod hf) ↦ sextcall_floatoflong_compatsem)
      ⊕ ((i64_utod hf) ↦ sextcall_floatoflongu_compatsem)
      ⊕ ((i64_stof hf) ↦ sextcall_singleoflong_compatsem)
      ⊕ ((i64_utof hf) ↦ sextcall_singleoflongu_compatsem)
      ⊕ ((i64_sdiv hf) ↦ sextcall_divls_compatsem)
      ⊕ ((i64_udiv hf) ↦ sextcall_divlu_compatsem)
      ⊕ ((i64_smod hf) ↦ sextcall_modls_compatsem)
      ⊕ ((i64_umod hf) ↦ sextcall_modlu_compatsem)
      ⊕ ((i64_shl hf) ↦ sextcall_shll_compatsem)
      ⊕ ((i64_shr hf) ↦ sextcall_shrlu_compatsem)
      ⊕ ((i64_sar hf) ↦ sextcall_shrl_compatsem).

  (** Prove that any layer [L ≥ L64] *which has no "magic"* yields a
  correct [ExternalCallI64helpers].*)

(** We guarantee that I64 helpers have a well-defined (and correct)
semantics only if the global environment matches some stencil. To this
end, we specified the [GenvValidOps] and [GenvValid] classes, which we
now need to instantiate accordingly. *)

  Definition stencil_valid {D} (s: stencil) (p: compatsem D): Prop :=
    match p with
      | inl p' => sextcall_valid p' s = true
      | _ => True
    end.

  Global Instance stencil_matches_genv_valid_ops {D} (L: _ D): GenvValidOps :=
    {
      genv_valid F V ge :=
        exists s, stencil_matches s ge /\
                  forall (i: ident) p, get_layer_primitive i L = OK (Some p) ->
                                       stencil_valid s p

    }.

  Global Instance stencil_matches_genv_valid {D} (L: _ D): GenvValid (genv_valid_ops := stencil_matches_genv_valid_ops L).
  Proof.
    constructor.
    intros.
    destruct VALID as (s & ? & ?).
    exists s.
    split; eauto; eapply stencil_matches_preserves_symbols; try eassumption; eauto.
  Qed.

  Theorem L64_correct:
    forall L, L64 ≤ L ->
              LayerOK L ->
              ExternalCallI64Helpers (genv_valid_ops := stencil_matches_genv_valid_ops L) (CompCertBuiltins.external_functions_sem (ExternalCallsOpsX := compatlayer_extcall_ops_x L)) hf.
  Proof.
    Opaque hf get_layer_primitive.
    unfold L64.
    intros.
    repeat split_le.
    constructor; simpl; intros; intro; intros;
    destruct VALID as (s & Hs & PRIMVALID);
    unfold stencil_valid in PRIMVALID;
    match goal with
      | [ H: ?i ↦ ?σ ≤ L |- context [ get_layer_primitive ?i L ] ] =>
        destruct (get_layer_primitive_mapsto_le_ok L i σ H) as (σ' & Hσ'eq & Hσ'le);
          rewrite Hσ'eq
    end;
    esplit; split; eauto;
    eapply compatsem_extcall_le; eauto;
    repeat (econstructor; eauto);
    try (intros s' Hmatch'; replace s' with s in * by (eapply stencil_matches_unique; eauto);
    eapply PRIMVALID; eauto; fail);
    econstructor; eauto.
  Qed.

End WITHSTENCIL.


From Perennial.program_proof.mvcc Require Import
     txn_prelude txnmgr_repr txn_repr
     wrbuf_proof.

Section program.
Context `{!heapGS Σ, !mvcc_ghostG Σ}.

(*****************************************************************)
(* func (txnMgr *TxnMgr) New() *Txn                              *)
(*****************************************************************)
Theorem wp_txnMgr__New txnmgr γ :
  is_txnmgr txnmgr γ -∗
  {{{ True }}}
    TxnMgr__New #txnmgr
  {{{ (txn : loc), RET #txn; own_txn_uninit txn γ }}}.
Proof.
  iIntros "#Htxnmgr" (Φ) "!> _ HΦ".
  iPoseProof "Htxnmgr" as "Htxnmgr'".
  iNamed "Htxnmgr".
  wp_call.

  (***********************************************************)
  (* txnMgr.latch.Lock()                                     *)
  (***********************************************************)
  wp_loadField.
  wp_apply (acquire_spec with "Hlock").
  iIntros "[Hlocked HtxnmgrOwn]".
  iNamed "HtxnmgrOwn".
  wp_pures.

  (***********************************************************)
  (* txn := new(Txn)                                         *)
  (***********************************************************)
  wp_apply (wp_allocStruct); first auto 10.
  iIntros (txn) "Htxn".
  iDestruct (struct_fields_split with "Htxn") as "Htxn".
  iNamed "Htxn".
  simpl.
  wp_pures.

  (***********************************************************)
  (* txn.wrbuf = wrbuf.MkWrBuf                               *)
  (***********************************************************)
  wp_apply (wp_MkWrBuf).
  iIntros (wrbuf) "HwrbufRP".
  wp_storeField.

  (***********************************************************)
  (* sid := txnMgr.sidCur                                    *)
  (* txn.sid = sid                                           *)
  (***********************************************************)
  wp_loadField.
  wp_pures.
  wp_storeField.

  (***********************************************************)
  (* txn.idx = txnMgr.idx                                    *)
  (* txn.txnMgr = txnMgr                                     *)
  (***********************************************************)
  wp_loadField.
  do 2 wp_storeField.

  (***********************************************************)
  (* txnMgr.sidCur = sid + 1                                 *)
  (* if txnMgr.sidCur == config.N_TXN_SITES {                *)
  (*     txnMgr.sidCur = 0                                   *)
  (* }                                                       *)
  (***********************************************************)
  wp_storeField.
  wp_loadField.
  wp_apply (wp_If_join_evar with "[Hsidcur]").
  { iIntros (b') "%Eb'".
    case_bool_decide.
    { wp_if_true.
      wp_storeField.
      iSplit; first done.
      replace (U64 0) with (if b' then (U64 0) else (word.add sidcur (U64 1))) by by rewrite Eb'.
      iNamedAccu.
    }
    { wp_if_false.
      iModIntro.
      subst.
      by iFrame "∗".
    }
  }
  iIntros "H".
  iNamed "H".
  wp_pures.

  (***********************************************************)
  (* txnMgr.latch.Unlock()                                   *)
  (* return txn                                              *)
  (***********************************************************)
  wp_loadField.
  wp_apply (release_spec with "[Hlocked Hsidcur]").
  { iFrame "Hlock Hlocked".
    iNext.
    unfold own_txnmgr.
    iExists _.
    iFrame.
    iSplit; last done.
    iPureIntro.
    case_bool_decide; first done.
    unfold N_TXN_SITES in *.
    apply Znot_le_gt in H.
    by apply Z.gt_lt.
  }
  wp_pures.
  iApply "HΦ".
  iMod (readonly_alloc_1 with "idx") as "#Hidx_txn".
  iMod (readonly_alloc_1 with "txnMgr") as "#Htxnmgr_txn".
  replace (int.nat 0) with 0%nat by word.
  simpl.
  eauto 20 with iFrame.
Qed.

End program.


(* Require Import StlcFix.SpecScoping. *)
(* Require Import StlcFix.LemmasScoping. *)
(* Require Import StlcFix.DecideEval. *)
Require Import LogRelFE.PseudoType.
Require Import LogRelFE.LemmasPseudoType.
Require Import LogRelFE.LR.
Require Import LogRelFE.LemmasLR.
Require Import LogRelFE.LemmasIntro.
Require Import Lia.
Require Import Db.Lemmas.

Require Import StlcFix.SpecEvaluation.
Require Import StlcFix.SpecSyntax.
Require Import StlcFix.SpecTyping.
Require Import StlcFix.SpecAnnot.
Require Import StlcFix.LemmasTyping.
Require Import StlcFix.LemmasEvaluation.
Require Import StlcFix.CanForm.
Require Import StlcFix.SpecEquivalent.
Require Import StlcFix.Size.

Require Import StlcEqui.SpecEvaluation.
Require Import StlcEqui.SpecSyntax.
Require Import StlcEqui.SpecTyping.
Require Import StlcEqui.SpecAnnot.
Require Import StlcEqui.LemmasTyping.
Require Import StlcEqui.LemmasEvaluation.
Require Import StlcEqui.CanForm.
Require Import StlcEqui.Fix.
Require Import StlcEqui.SpecEquivalent.
Require Import StlcEqui.Size.

Module F.
  Include StlcFix.SpecEvaluation.
  Include StlcFix.SpecSyntax.
  Include StlcFix.SpecTyping.
  Include StlcFix.SpecAnnot.
  Include StlcFix.LemmasTyping.
  Include StlcFix.LemmasEvaluation.
  Include StlcFix.CanForm.
  Include StlcFix.Size.
End F.

Module E.
  Include StlcEqui.SpecEvaluation.
  Include StlcEqui.SpecSyntax.
  Include StlcEqui.SpecTyping.
  Include StlcEqui.SpecAnnot.
  Include StlcEqui.LemmasTyping.
  Include StlcEqui.LemmasEvaluation.
  Include StlcEqui.CanForm.
  Include StlcEqui.Fix.
  Include StlcEqui.Size.
End E.

Fixpoint compfe_ty (τ : F.Ty) : E.Ty :=
  match τ with
    | F.tunit => E.tunit
    | F.tbool => E.tbool
    | F.tprod τ1 τ2 => E.tprod (compfe_ty τ1) (compfe_ty τ2)
    | F.tarr τ1 τ2 => E.tarr (compfe_ty τ1) (compfe_ty τ2)
    | F.tsum τ1 τ2 => E.tsum (compfe_ty τ1) (compfe_ty τ2)
  end.

Lemma validTy_compfe_ty {τ} : ValidTy (compfe_ty τ).
Proof.
  induction τ; cbn; crushValidTy.
Qed.

Fixpoint compfe_env (Γ : F.Env) : E.Env :=
  match Γ with
    | F.empty => E.empty
    | F.evar Γ τ => E.evar (compfe_env Γ) (compfe_ty τ)
  end.

Fixpoint compfe (t : F.Tm) : E.Tm :=
  match t with
    | F.var x => E.var x
    | F.abs τ t => E.abs (compfe_ty τ) (compfe t)
    | F.app t1 t2 => E.app (compfe t1) (compfe t2)
    | F.unit => E.unit
    | F.true => E.true
    | F.false => E.false
    | F.ite t1 t2 t3 => E.ite (compfe t1) (compfe t2) (compfe t3)
    | F.pair t1 t2 => E.pair (compfe t1) (compfe t2)
    | F.proj₁ t => E.proj₁ (compfe t)
    | F.proj₂ t => E.proj₂ (compfe t)
    | F.inl t => E.inl (compfe t)
    | F.inr t => E.inr (compfe t)
    | F.caseof t1 t2 t3 => E.caseof (compfe t1) (compfe t2) (compfe t3)
    | F.seq t1 t2 => E.seq (compfe t1) (compfe t2)
    | F.fixt τ1 τ2 t => E.app (E.ufix (compfe_ty τ1) (compfe_ty τ2)) (compfe t)
  end.

Fixpoint compfe_annot (t : F.TmA) : E.TmA :=
  match t with
    | F.a_var x => E.ea_var x
    | F.a_abs τ₁ τ₂ t => E.ea_abs (compfe_ty τ₁) (compfe_ty τ₂) (compfe_annot t)
    | F.a_app τ₁ τ₂ t1 t2 => E.ea_app (compfe_ty τ₁) (compfe_ty τ₂) (compfe_annot t1) (compfe_annot t2)
    | F.a_unit => E.ea_unit
    | F.a_true => E.ea_true
    | F.a_false => E.ea_false
    | F.a_ite τ t1 t2 t3 => E.ea_ite (compfe_ty τ) (compfe_annot t1) (compfe_annot t2) (compfe_annot t3)
    | F.a_pair τ₁ τ₂ t1 t2 => E.ea_pair (compfe_ty τ₁) (compfe_ty τ₂) (compfe_annot t1) (compfe_annot t2)
    | F.a_proj₁ τ₁ τ₂ t => E.ea_proj₁ (compfe_ty τ₁) (compfe_ty τ₂) (compfe_annot t)
    | F.a_proj₂ τ₁ τ₂ t => E.ea_proj₂ (compfe_ty τ₁) (compfe_ty τ₂) (compfe_annot t)
    | F.a_inl τ₁ τ₂ t => E.ea_inl (compfe_ty τ₁) (compfe_ty τ₂) (compfe_annot t)
    | F.a_inr τ₁ τ₂ t => E.ea_inr (compfe_ty τ₁) (compfe_ty τ₂) (compfe_annot t)
    | F.a_caseof τ₁ τ₂ τ t1 t2 t3 => E.ea_caseof (compfe_ty τ₁) (compfe_ty τ₂) (compfe_ty τ) (compfe_annot t1) (compfe_annot t2) (compfe_annot t3)
    | F.a_seq τ t₁ t₂ => E.ea_seq (compfe_ty τ) (compfe_annot t₁) (compfe_annot t₂)
    | F.a_fixt τ1 τ2 t => E.ea_app (tarr (tarr (compfe_ty τ1) (compfe_ty τ2)) (tarr (compfe_ty τ1) (compfe_ty τ2))) (tarr (compfe_ty τ1) (compfe_ty τ2)) (E.ufix_annot (compfe_ty τ1) (compfe_ty τ2)) (compfe_annot t)
  end.

(* The two compiler definitions are the same modulo type annotations. *)
Lemma compfe_compfe_annot {t} :
  compfe (F.eraseAnnot t) = E.eraseAnnot (compfe_annot t).
Proof.
  induction t; cbn; f_equal; try assumption; try reflexivity.
Qed.

Fixpoint compfe_pctx_annot (C : F.PCtxA) : E.PCtxA :=
  match C with
  | F.a_phole => E.ea_phole
  | F.a_pabs τ₁ τ₂ C => E.ea_pabs (compfe_ty τ₁) (compfe_ty τ₂) (compfe_pctx_annot C)
  | F.a_papp₁ τ₁ τ₂ C t => E.ea_papp₁ (compfe_ty τ₁) (compfe_ty τ₂) (compfe_pctx_annot C) (compfe_annot t)
  | F.a_papp₂ τ₁ τ₂ t C => E.ea_papp₂ (compfe_ty τ₁) (compfe_ty τ₂) (compfe_annot t) (compfe_pctx_annot C)
  | F.a_pite₁ τ C t₂ t₃ => E.ea_pite₁ (compfe_ty τ) (compfe_pctx_annot C) (compfe_annot t₂) (compfe_annot t₃)
  | F.a_pite₂ τ t₁ C t₃ => E.ea_pite₂ (compfe_ty τ) (compfe_annot t₁) (compfe_pctx_annot C) (compfe_annot t₃)
  | F.a_pite₃ τ t₁ t₂ C => E.ea_pite₃ (compfe_ty τ) (compfe_annot t₁) (compfe_annot t₂) (compfe_pctx_annot C)
  | F.a_ppair₁ τ₁ τ₂ C t => E.ea_ppair₁ (compfe_ty τ₁) (compfe_ty τ₂) (compfe_pctx_annot C) (compfe_annot t)
  | F.a_ppair₂ τ₁ τ₂ t C => E.ea_ppair₂ (compfe_ty τ₁) (compfe_ty τ₂) (compfe_annot t) (compfe_pctx_annot C)
  | F.a_pproj₁ τ₁ τ₂ C => E.ea_pproj₁ (compfe_ty τ₁) (compfe_ty τ₂) (compfe_pctx_annot C)
  | F.a_pproj₂ τ₁ τ₂ C => E.ea_pproj₂ (compfe_ty τ₁) (compfe_ty τ₂) (compfe_pctx_annot C)
  | F.a_pinl τ₁ τ₂ C => E.ea_pinl (compfe_ty τ₁) (compfe_ty τ₂) (compfe_pctx_annot C)
  | F.a_pinr τ₁ τ₂ C => E.ea_pinr (compfe_ty τ₁) (compfe_ty τ₂) (compfe_pctx_annot C)
  | F.a_pcaseof₁ τ₁ τ₂ τ C t₂ t₃ => E.ea_pcaseof₁ (compfe_ty τ₁) (compfe_ty τ₂) (compfe_ty τ) (compfe_pctx_annot C) (compfe_annot t₂) (compfe_annot t₃)
  | F.a_pcaseof₂ τ₁ τ₂ τ t₁ C t₃ => E.ea_pcaseof₂ (compfe_ty τ₁) (compfe_ty τ₂) (compfe_ty τ) (compfe_annot t₁) (compfe_pctx_annot C) (compfe_annot t₃)
  | F.a_pcaseof₃ τ₁ τ₂ τ t₁ t₂ C => E.ea_pcaseof₃ (compfe_ty τ₁) (compfe_ty τ₂) (compfe_ty τ) (compfe_annot t₁) (compfe_annot t₂) (compfe_pctx_annot C)
  | F.a_pseq₁ τ C t₂ => E.ea_pseq₁ (compfe_ty τ) (compfe_pctx_annot C) (compfe_annot t₂)
  | F.a_pseq₂ τ t₁ C => E.ea_pseq₂ (compfe_ty τ) (compfe_annot t₁) (compfe_pctx_annot C)
  | F.a_pfixt τ₁ τ₂ C => E.ea_papp₂ (tarr (tarr (compfe_ty τ₁) (compfe_ty τ₂)) (tarr (compfe_ty τ₁) (compfe_ty τ₂)))
                                   (tarr (compfe_ty τ₁) (compfe_ty τ₂))
                                   (E.ufix_annot (compfe_ty τ₁) (compfe_ty τ₂))
                                   (compfe_pctx_annot C)
  end.

Lemma smoke_test_compiler :
  (compfe_annot F.a_unit) = E.ea_unit.
Proof.
  simpl. reflexivity.
Qed.

Lemma compfe_getevar_works {i τ Γ} :
  ⟪ i : τ ∈ Γ ⟫ →
  ⟪ i : compfe_ty τ r∈ compfe_env Γ ⟫.
Proof.
  induction 1; constructor; assumption.
Qed.

Lemma compfe_typing_works {Γ t τ} :
  ⟪ Γ ⊢ t : τ ⟫ →
  ⟪ compfe_env Γ e⊢ compfe t : compfe_ty τ ⟫.
Proof.
  induction 1; F.crushTyping; E.crushTyping; eauto using E.AnnotTyping, compfe_getevar_works, E.ufix_typing, validTy_compfe_ty.
Qed.

Lemma compfe_annot_typing_works {Γ t τ} :
  ⟪ Γ a⊢ t : τ ⟫ →
  ⟪ compfe_env Γ ea⊢ compfe_annot t : compfe_ty τ ⟫.
Proof.
  induction 1; F.crushTyping; E.crushTyping; eauto using E.AnnotTyping, compfe_getevar_works, E.ufix_annot_typing, validTy_compfe_ty.
Qed.

Lemma compfe_pctx_annot_typing_works {C Γ Γ' τ τ'} :
  ⟪ a⊢ C : Γ, τ → Γ', τ' ⟫ →
  ⟪ ea⊢ compfe_pctx_annot C : compfe_env Γ, compfe_ty τ →
  compfe_env Γ', compfe_ty τ' ⟫.
Proof.
  induction 1; eauto using PCtxTypingAnnot, compfe_typing_works, validTy_compfe_ty.
  - eapply compfe_annot_typing_works in H0.
    eauto using PCtxTypingAnnot, compfe_typing_works, validTy_compfe_ty with tyvalid.
  - eapply compfe_annot_typing_works in H.
    eauto using PCtxTypingAnnot, compfe_typing_works, validTy_compfe_ty with tyvalid.
  - eapply compfe_annot_typing_works in H0, H1.
    eauto using PCtxTypingAnnot, compfe_typing_works.
  - eapply compfe_annot_typing_works in H, H1.
    eauto using PCtxTypingAnnot, compfe_typing_works.
  - eapply compfe_annot_typing_works in H, H0.
    eauto using PCtxTypingAnnot, compfe_typing_works.
  - eapply compfe_annot_typing_works in H0.
    eauto using PCtxTypingAnnot, compfe_typing_works.
  - eapply compfe_annot_typing_works in H.
    eauto using PCtxTypingAnnot, compfe_typing_works.
  - eauto using PCtxTypingAnnot, compfe_typing_works, validTy_compfe_ty with tyvalid.
  - eauto using PCtxTypingAnnot, compfe_typing_works, validTy_compfe_ty with tyvalid.
  - eapply compfe_annot_typing_works in H0, H1.
    eauto using PCtxTypingAnnot, compfe_typing_works, validTy_compfe_ty.
  - eapply compfe_annot_typing_works in H, H1.
    eauto using PCtxTypingAnnot, compfe_typing_works, validTy_compfe_ty.
  - eapply compfe_annot_typing_works in H, H0.
    eauto using PCtxTypingAnnot, compfe_typing_works, validTy_compfe_ty.
  - eapply compfe_annot_typing_works in H0.
    eauto using PCtxTypingAnnot, compfe_typing_works, E.ufix_annot_typing.
  - eapply compfe_annot_typing_works in H.
    eauto using PCtxTypingAnnot, compfe_typing_works, E.ufix_annot_typing.
  - eauto using PCtxTypingAnnot, compfe_typing_works, E.ufix_annot_typing, validTy_compfe_ty with tyvalid2.
    cbn.
    constructor; eauto using ufix_annot_typing, validTy_compfe_ty with tyvalid.
Qed.

Lemma compileCtx_works {Γ i τ} :
  F.GetEvar Γ i τ →
  ⟪ i : embed τ p∈ embedCtx Γ ⟫.
Proof.
  induction 1; eauto using GetEvarP.
Qed.

Local Ltac crush :=
  cbn in * |- ;
  repeat
    (cbn;
     repeat crushLRMatch;
     crushOfType;
     F.crushTyping;
     E.crushTyping;
     repeat crushRepEmulEmbed;
     repeat crushRecTypesMatchH;
     repeat F.crushStlcSyntaxMatchH;
     repeat E.crushStlcSyntaxMatchH;
     subst;
     trivial
    ); try lia; eauto.

Lemma compiler_is_fxToIs_embed :
  ∀ τ : F.Ty, compfe_ty τ = fxToIs (embed τ).
Proof.
  induction τ; simpl;
    try rewrite IHτ1; try rewrite IHτ2;
      reflexivity.
Qed.

Lemma compiler_is_fxToIs_embed_env :
  ∀ Γ : F.Env, compfe_env Γ = fxToIsCtx (embedCtx Γ).
Proof.
  induction Γ; crush; apply compiler_is_fxToIs_embed.
Qed.

Section CompatibilityLemmas.

  Lemma compat_lambda {Γ τ' ts d n tu τ} :
    ValidPTy τ -> ValidPTy τ' -> ValidPEnv Γ ->
    ⟪ Γ p▻ τ' ⊩ ts ⟦ d , n ⟧ tu : τ ⟫ →
    ⟪ Γ ⊩ (F.abs (repEmul τ') ts) ⟦ d , n ⟧ (E.abs (fxToIs τ') tu) : ptarr τ' τ ⟫.
  Proof.
    crush.
    - eauto using E.wtSub_up, envrel_implies_WtSub_equi, validTy_fxToIs.
    - eauto using validTy_fxToIs.
    - eauto using E.wtSub_up, envrel_implies_WtSub_equi, validTy_fxToIs.
    - eauto using validTy_fxToIs.
    - eauto using F.wtSub_up, envrel_implies_WtSub, validTy_fxToIs.
    - repeat eexists; try reflexivity.
      intros w' fw vs vu szvu vr.
      rewrite -> ?ap_comp.
      apply H4; [lia|].
      eauto using extend_envrel, envrel_mono.
  Qed.

  Lemma compat_lambda_embed {Γ τ' ts d n tu τ} :
    ValidPEnv Γ -> ValidPTy τ ->
    ⟪ Γ p▻ embed τ' ⊩ ts ⟦ d , n ⟧ tu : τ ⟫ →
    ⟪ Γ ⊩ (F.abs τ' ts) ⟦ d , n ⟧ (E.abs (fxToIs (embed τ')) tu) : ptarr (embed τ') τ ⟫.
  Proof.
    intros vΓ vτ.
    rewrite <- (repEmul_embed_leftinv τ') at 2.
    apply compat_lambda; eauto using validPTy_embed.
  Qed.

  Lemma compat_lambda_embed' {Γ τ' ts d n tu τ} :
    ValidPEnv Γ -> ValidPTy τ ->
    ⟪ Γ p▻ embed τ' ⊩ ts ⟦ d , n ⟧ tu : τ ⟫ →
    ⟪ Γ ⊩ (F.abs τ' ts) ⟦ d , n ⟧ (E.abs (compfe_ty τ') tu) : ptarr (embed τ') τ ⟫.
  Proof.
    rewrite (compiler_is_fxToIs_embed τ').
    apply compat_lambda_embed.
  Qed.

  Lemma compat_unit {Γ d n} :
    ⟪ Γ ⊩ F.unit ⟦ d , n ⟧ E.unit : ptunit ⟫.
  Proof.
    crush.
  Qed.

  Lemma compat_true {Γ d n} :
    ⟪ Γ ⊩ F.true ⟦ d , n ⟧ E.true : ptbool ⟫.
  Proof.
    crush.
  Qed.

  Lemma compat_false {Γ d n} :
    ⟪ Γ ⊩ F.false ⟦ d , n ⟧ E.false : ptbool ⟫.
  Proof.
    crush.
  Qed.

  Lemma compat_pair {Γ d n ts₁ tu₁ τ₁ ts₂ tu₂ τ₂} :
    ValidPEnv Γ -> ValidPTy τ₁ -> ValidPTy τ₂ ->
    ⟪ Γ ⊩ ts₁ ⟦ d , n ⟧ tu₁ : τ₁ ⟫ →
    ⟪ Γ ⊩ ts₂ ⟦ d , n ⟧ tu₂ : τ₂ ⟫ →
    ⟪ Γ ⊩ F.pair ts₁ ts₂ ⟦ d , n ⟧ E.pair tu₁ tu₂ : ptprod τ₁ τ₂ ⟫.
  Proof.
    crush.
    apply termrel_pair; crush.
    refine (H5 w' _ _ _ _); unfold lev in *; try lia.
    eauto using envrel_mono.
  Qed.

  Lemma compat_app {Γ d n ts₁ tu₁ τ₁ ts₂ tu₂ τ₂} :
    ValidPEnv Γ -> ValidPTy τ₁ -> ValidPTy τ₂ ->
    ⟪ Γ ⊩ ts₁ ⟦ d , n ⟧ tu₁ : ptarr τ₁ τ₂ ⟫ →
    ⟪ Γ ⊩ ts₂ ⟦ d , n ⟧ tu₂ : τ₁ ⟫ →
    ⟪ Γ ⊩ F.app ts₁ ts₂ ⟦ d , n ⟧ E.app tu₁ tu₂ : τ₂ ⟫.
  Proof.
    intros vΓ vτ₁ vτ₂.
    crush.
    refine (termrel_app vτ₁ _ _ _); crush.
    refine (H2 w' _ _ _ _); unfold lev in *; try lia.
    eauto using envrel_mono.
  Qed.

  Lemma compat_inl {Γ d n ts tu τ₁ τ₂} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    ⟪ Γ ⊩ ts ⟦ d , n ⟧ tu : τ₁ ⟫ →
    ⟪ Γ ⊩ F.inl ts ⟦ d , n ⟧ E.inl tu : ptsum τ₁ τ₂ ⟫.
  Proof.
    crush; eauto using validTy_fxToIs.
    refine (termrel_inl _ _ _); crush.
  Qed.

  Lemma compat_inr {Γ d n ts tu τ₁ τ₂} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    ⟪ Γ ⊩ ts ⟦ d , n ⟧ tu : τ₂ ⟫ →
    ⟪ Γ ⊩ F.inr ts ⟦ d , n ⟧ E.inr tu : ptsum τ₁ τ₂ ⟫.
  Proof.
    crush; eauto using validTy_fxToIs.
    refine (termrel_inr _ _ _); crush.
  Qed.

  Lemma compat_seq {Γ d n ts₁ tu₁ ts₂ tu₂ τ₂} :
    ValidPEnv Γ -> ValidPTy τ₂ ->
    ⟪ Γ ⊩ ts₁ ⟦ d , n ⟧ tu₁ : ptunit ⟫ →
    ⟪ Γ ⊩ ts₂ ⟦ d , n ⟧ tu₂ : τ₂ ⟫ →
    ⟪ Γ ⊩ F.seq ts₁ ts₂ ⟦ d , n ⟧ E.seq tu₁ tu₂ : τ₂ ⟫.
  Proof.
    crush.
    apply termrel_seq; crush.
    refine (H4 w' _ _ _ _); crush.
    eauto using envrel_mono.
  Qed.

  Lemma compat_proj₂ {Γ d n ts tu τ₁ τ₂} :
    ValidPEnv Γ -> ValidPTy τ₁ -> ValidPTy τ₂ ->
    ⟪ Γ ⊩ ts ⟦ d , n ⟧ tu : ptprod τ₁ τ₂ ⟫ →
    ⟪ Γ ⊩ F.proj₂ ts ⟦ d , n ⟧ E.proj₂ tu : τ₂ ⟫.
  Proof.
    intros vΓ vτ₁ vτ₂.
    crush.
    refine (termrel_proj₂ vτ₁ _ _); crush.
  Qed.

  Lemma compat_proj₁ {Γ d n ts tu τ₁ τ₂} :
    ValidPEnv Γ -> ValidPTy τ₁ -> ValidPTy τ₂ ->
    ⟪ Γ ⊩ ts ⟦ d , n ⟧ tu : ptprod τ₁ τ₂ ⟫ →
    ⟪ Γ ⊩ F.proj₁ ts ⟦ d , n ⟧ E.proj₁ tu : τ₁ ⟫.
  Proof.
    intros vΓ vτ₁ vτ₂.
    crush.
    refine (termrel_proj₁ vτ₁ vτ₂ _); crush.
  Qed.

  Lemma compat_ite {Γ d n ts₁ tu₁ ts₂ tu₂ ts₃ tu₃ τ} :
    ValidPEnv Γ -> ValidPTy τ ->
    ⟪ Γ ⊩ ts₁ ⟦ d , n ⟧ tu₁ : ptbool ⟫ →
    ⟪ Γ ⊩ ts₂ ⟦ d , n ⟧ tu₂ : τ ⟫ →
    ⟪ Γ ⊩ ts₃ ⟦ d , n ⟧ tu₃ : τ ⟫ →
    ⟪ Γ ⊩ F.ite ts₁ ts₂ ts₃ ⟦ d , n ⟧ E.ite tu₁ tu₂ tu₃ : τ ⟫.
  Proof.
    crush.
    apply termrel_ite; crush.
    - refine (H7 w' _ _ _ _); crush.
      eauto using envrel_mono.
    - refine (H5 w' _ _ _ _); crush.
      eauto using envrel_mono.
  Qed.

  Lemma compat_caseof {Γ d n ts₁ tu₁ ts₂ tu₂ ts₃ tu₃ τ₁ τ₂ τ} :
    ValidPEnv Γ -> ValidPTy τ₁ -> ValidPTy τ₂ ->
    ⟪ Γ ⊩ ts₁ ⟦ d , n ⟧ tu₁ : ptsum τ₁ τ₂ ⟫ →
    ⟪ Γ p▻ τ₁ ⊩ ts₂ ⟦ d , n ⟧ tu₂ : τ ⟫ →
    ⟪ Γ p▻ τ₂ ⊩ ts₃ ⟦ d , n ⟧ tu₃ : τ ⟫ →
    ⟪ Γ ⊩ F.caseof ts₁ ts₂ ts₃ ⟦ d , n ⟧ E.caseof tu₁ tu₂ tu₃ : τ ⟫.
  Proof.
    intros vΓ vτ₁ vτ₂.
    crush; eauto using validTy_fxToIs.
    refine (termrel_caseof vτ₁ vτ₂ _ _ _); crush;
    rewrite -> ?ap_comp.
    - refine (H5 w' _ _ _ _); [lia|].
      eauto using extend_envrel, envrel_mono.
    - refine (H3 w' _ _ _ _); [lia|].
      eauto using extend_envrel, envrel_mono.
  Qed.

  Lemma compat_fix {Γ d n ts tu τ₁ τ₂} :
    ValidPEnv Γ -> ValidPTy τ₁ -> ValidPTy τ₂ ->
    ⟪ Γ ⊩ ts ⟦ d , n ⟧ tu : ptarr (ptarr τ₁ τ₂) (ptarr τ₁ τ₂) ⟫ →
    ⟪ Γ ⊩ F.fixt (repEmul τ₁) (repEmul τ₂) ts ⟦ d , n ⟧ E.app (E.ufix (fxToIs τ₁) (fxToIs τ₂)) tu : ptarr τ₁ τ₂ ⟫.
  Proof.
    crush.
    - eauto using E.ufix_typing, validTy_fxToIs.
    - refine (termrel_fix _ _ _); crush.
  Qed.

  Lemma compat_fix' {Γ d n ts tu τ₁ τ₂} :
    ValidPEnv Γ ->
    ⟪ Γ ⊩ ts ⟦ d , n ⟧ tu : embed (F.tarr (F.tarr τ₁ τ₂) (F.tarr τ₁ τ₂)) ⟫ →
    ⟪ Γ ⊩ F.fixt τ₁ τ₂ ts ⟦ d , n ⟧ E.app (E.ufix (compfe_ty τ₁) (compfe_ty τ₂)) tu : ptarr (embed τ₁) (embed τ₂) ⟫.
  Proof.
    intros vΓ tr.
    rewrite <- (repEmul_embed_leftinv τ₁) at 1.
    rewrite <- (repEmul_embed_leftinv τ₂) at 1.
    rewrite (compiler_is_fxToIs_embed τ₁) at 1.
    rewrite (compiler_is_fxToIs_embed τ₂) at 1.
    apply compat_fix; eauto using validPTy_embed.
  Qed.

  Lemma compat_fix'' {Γ d n ts tu τ₁ τ₂} :
    ValidPEnv Γ ->
    ⟪ Γ ⊩ ts ⟦ d , n ⟧ tu : embed (F.tarr (F.tarr τ₁ τ₂) (F.tarr τ₁ τ₂)) ⟫ →
    ⟪ Γ ⊩ F.fixt τ₁ τ₂ ts ⟦ d , n ⟧ E.app (E.ufix (fxToIs (embed τ₁)) (fxToIs (embed τ₂))) tu : ptarr (embed τ₁) (embed τ₂) ⟫.
  Proof.
    rewrite <- (compiler_is_fxToIs_embed τ₁) at 1.
    rewrite <- (compiler_is_fxToIs_embed τ₂) at 1.
    exact compat_fix'.
  Qed.

  Lemma compfe_correct {Γ d n ts τ} :
    ⟪ Γ ⊢ ts : τ ⟫ →
    ⟪ embedCtx Γ ⊩ ts ⟦ d , n ⟧ compfe ts : embed τ ⟫.
  Proof.
    induction 1;
      cbn -[E.ufix_annot E.ufix₁_annot];
      rewrite ?compiler_is_fxToIs_embed, ?eraseAnnot_ufix;
      eauto using compat_inl
      , compat_inr
      , compat_pair
      , compat_lambda_embed
      , compat_app
      , compat_false, compat_true
      , compat_var
      , compat_unit
      , embedCtx_works
      , compat_seq
      , compat_ite, compat_proj₁, compat_proj₂
      , compat_caseof
      , compat_fix''
      , validPTy_embed
      , validPEnv_embedCtx.
  Qed.

  Lemma compfe_correct' {Γ d n ts τ τ'} :
    ⟪ Γ ⊢ ts : τ ⟫ →
    τ' = embed τ ->
    ⟪ embedCtx Γ ⊩ ts ⟦ d , n ⟧ compfe ts : τ' ⟫.
  Proof.
    intros; subst; now eapply compfe_correct.
  Qed.

  Lemma compfe_annot_correct {Γ d n ts τ} :
    ⟪ Γ a⊢ ts : τ ⟫ →
    ⟪ embedCtx Γ ⊩ F.eraseAnnot ts ⟦ d , n ⟧ E.eraseAnnot (compfe_annot ts) : embed τ ⟫.
  Proof.
    induction 1;
      cbn -[E.ufix_annot E.ufix₁_annot];
      rewrite ?compiler_is_fxToIs_embed, ?eraseAnnot_ufix;
      eauto using compat_inl
      , compat_inr
      , compat_pair
      , compat_lambda_embed
      , compat_app
      , compat_false, compat_true
      , compat_var
      , compat_unit
      , embedCtx_works
      , compat_seq
      , compat_ite, compat_proj₁, compat_proj₂
      , compat_caseof
      , compat_fix''
      , validPTy_embed
      , validPEnv_embedCtx.
  Qed.

  Lemma compfe_ctx_correct {Γ Γ' d n C τ τ'} :
    ⟪ a⊢ C : Γ , τ → Γ' , τ'⟫ →
    ⟪ ⊩ F.eraseAnnot_pctx C ⟦ d , n ⟧ eraseAnnot_pctx (compfe_pctx_annot C) : embedCtx Γ , embed τ → embedCtx Γ' , embed τ' ⟫.
  Proof.
    intros ty; unfold OpenLRCtxN; split; [|split];
      rewrite <-?compiler_is_fxToIs_embed in *;
      rewrite <-?compiler_is_fxToIs_embed_env in *;
      rewrite ?repEmul_embed_leftinv in *;
      rewrite ?repEmulCtx_embedCtx_leftinv in *;
      eauto using F.eraseAnnot_pctxT, E.eraseAnnot_pctxT, compfe_pctx_annot_typing_works, F.pctxtyping_app, F.eraseAnnot_pctxT, E.pctxtyping_app, E.eraseAnnot_pctxT.

    induction ty; simpl;
    intros ts tu lr;
      try assumption; (* deal with phole *)
      specialize (IHty ts tu lr);
      rewrite <-?compfe_compfe_annot;
      repeat (try match goal with
             | [ |- ⟪_⊩ F.abs _ _ ⟦d,n⟧ E.abs _ _ : _ ⟫ ] => eapply compat_lambda_embed'
             | [ |- ⟪_⊩ F.app _ _ ⟦d,n⟧ E.app _ _ : _ ⟫ ] => eapply compat_app
             | [ |- ⟪_⊩ F.ite _ _ _ ⟦d,n⟧ E.ite _ _ _ : _ ⟫ ] => eapply compat_ite
             | [ |- ⟪_⊩ F.pair _ _ ⟦d,n⟧ E.pair _ _ : _ ⟫ ] => eapply compat_pair
             | [ |- ⟪_⊩ F.inl _ ⟦d,n⟧ E.inl _ : _ ⟫ ] => eapply compat_inl
             | [ |- ⟪_⊩ F.inr _ ⟦d,n⟧ E.inr _ : _ ⟫ ] => eapply compat_inr
             | [ |- ⟪_⊩ F.proj₁ _ ⟦d,n⟧ E.proj₁ _ : _ ⟫ ] => eapply compat_proj₁
             | [ |- ⟪_⊩ F.proj₂ _ ⟦d,n⟧ E.proj₂ _ : _ ⟫ ] => eapply compat_proj₂
             | [ |- ⟪_⊩ F.fixt _ _ _ ⟦d,n⟧ _ : _ ⟫ ] => eapply compat_fix'
             | [ |- ⟪_⊩ F.caseof _ _ _ ⟦d,n⟧ E.caseof _ _ _ : _ ⟫ ] => eapply compat_caseof
             | [ |- ⟪_⊩ F.seq _ _ ⟦d,n⟧ E.seq _ _ : _ ⟫ ] => eapply compat_seq
             (* | [ |- context[ ptarr (embed ?τ1) (embed ?τ2) ]] => *)
             (*   change (ptarr (embed τ1) (embed τ2)) with (embed (F.tarr τ1 τ2)) *)
             | [ |- ⟪_⊩ _ ⟦d,n⟧ compfe _ : _ ⟫ ] => eapply compfe_correct'
             | [ |- ⟪ _ ⊢ F.eraseAnnot _ : _ ⟫ ] => eapply F.eraseAnnotT
             | [ |- ⟪ _ ⊢ E.eraseAnnot _ : _ ⟫ ] => eapply E.eraseAnnotT
              end;
              eauto using validPTy_embed, validPEnv_embedCtx;
              try eassumption;
              fold embed;
              try reflexivity;
              change (embedCtx ?Γ p▻ embed ?τ) with (embedCtx (Γ ▻ τ))).
  Qed.

End CompatibilityLemmas.

Lemma equivalenceReflection {Γ t₁ t₂ τ} :
  ⟪ Γ ⊢ t₁ : τ ⟫ →
  ⟪ Γ ⊢ t₂ : τ ⟫ →
  ⟪ compfe_env Γ e⊢ compfe t₁ ≃ compfe t₂ : compfe_ty τ ⟫ →
  ⟪ Γ ⊢ t₁ ≃ t₂ : τ ⟫.
Proof.
  revert t₁ t₂ τ.
  enough (∀ {t₁ t₂} τ,
            ⟪ Γ ⊢ t₁ : τ ⟫ →
            ⟪ Γ ⊢ t₂ : τ ⟫ →
            ⟪ compfe_env Γ e⊢ compfe t₁ ≃ compfe t₂ : compfe_ty τ ⟫ →
            ∀ C τ',
              ⟪ a⊢ C : Γ , τ → F.empty, τ' ⟫ →
                    F.Terminating (F.pctx_app t₁ (F.eraseAnnot_pctx C)) → F.Terminating (F.pctx_app t₂ (F.eraseAnnot_pctx C))) as Hltor
  by (intros t₁ t₂ τ ty1 ty2 eq C τ';
      assert (⟪ compfe_env Γ e⊢ compfe t₂ ≃ compfe t₁ : compfe_ty τ ⟫)
        by (apply E.pctx_equiv_symm; assumption);
  split;
  refine (Hltor _ _ τ _ _ _ C τ' _); assumption).

  intros t₁ t₂ τ ty1 ty2 eq C τ' tyC term.

  destruct (F.Terminating_TermHor term) as [n termN]; clear term.

  assert (⟪ embedCtx Γ ⊩ t₁ ⟦ dir_lt , S n ⟧ compfe t₁ : embed τ ⟫) as lrt₁ by exact (compfe_correct ty1).

  assert (⟪ ⊩ (F.eraseAnnot_pctx C) ⟦ dir_lt , S n ⟧ E.eraseAnnot_pctx (compfe_pctx_annot C) : embedCtx Γ , embed τ → pempty , embed τ' ⟫) as lrC_lt
      by apply (compfe_ctx_correct tyC).

  apply lrC_lt in lrt₁.

  assert (E.Terminating (E.pctx_app (compfe t₁) (E.eraseAnnot_pctx (compfe_pctx_annot C))))
    as termu₁ by (apply (adequacy_lt lrt₁ termN); lia).

  assert (E.Terminating (E.pctx_app (compfe t₂) (E.eraseAnnot_pctx (compfe_pctx_annot C)))).
  eapply eq; try assumption; eauto using compfe_pctx_annot_typing_works, validTy_compfe_ty.
  apply (compfe_pctx_annot_typing_works tyC).

  destruct (E.Terminating_TermHor H) as [n' termN']; clear H.

  assert (⟪ ⊩ F.eraseAnnot_pctx C ⟦ dir_gt , S n' ⟧ E.eraseAnnot_pctx (compfe_pctx_annot C) : embedCtx Γ , embed τ → pempty , embed τ' ⟫) as lrC_gt
    by (apply (compfe_ctx_correct tyC)).

  assert (⟪ embedCtx Γ ⊩ t₂ ⟦ dir_gt , S n' ⟧ compfe t₂ : embed τ ⟫) as lrt₂ by exact (compfe_correct ty2).

  apply lrC_gt in lrt₂.

  apply (adequacy_gt lrt₂ termN'); lia.
Qed.

Lemma equivalenceReflectionEmpty {t₁ t₂ τ} :
  ⟪ F.empty ⊢ t₁ : τ ⟫ →
  ⟪ F.empty ⊢ t₂ : τ ⟫ →
  ⟪ E.empty e⊢ compfe t₁ ≃ compfe t₂ : compfe_ty τ ⟫ →
  ⟪ F.empty ⊢ t₁ ≃ t₂ : τ ⟫.
Proof.
  apply @equivalenceReflection.
Qed.