From stdpp Require Export namespaces.
From iris.algebra Require Import reservation_map agree frac.
From iris.algebra Require Export dfrac.
From iris.bi.lib Require Import fractional.
From iris.proofmode Require Import tactics.
From iris.base_logic.lib Require Export own.
From iris.base_logic.lib Require Import ghost_map.
From iris.prelude Require Import options.
Import uPred.

(** This file provides a generic mechanism for a language-level point-to
connective [l ↦{dq} v] reflecting the physical heap.  This library is designed to
be used as a singleton (i.e., with only a single instance existing in any
proof), with the [gen_heapG] typeclass providing the ghost names of that unique
instance.  That way, [mapsto] does not need an explicit [gname] parameter.
This mechanism can be plugged into a language and related to the physical heap
by using [gen_heap_interp σ] in the state interpretation of the weakest
precondition. See heap-lang for an example.

If you are looking for a library providing "ghost heaps" independent of the
physical state, you will likely want explicit ghost names to disambiguate
multiple heaps and are thus better off using [ghost_map], or (if you need more
flexibility), directly using the underlying [algebra.lib.gmap_view].

This library is generic in the types [L] for locations and [V] for values and
supports fractional permissions.  Next to the point-to connective [l ↦{dq} v],
which keeps track of the value [v] of a location [l], this library also provides
a way to attach "meta" or "ghost" data to locations. This is done as follows:

- When one allocates a location, in addition to the point-to connective [l ↦ v],
  one also obtains the token [meta_token l ⊤]. This token is an exclusive
  resource that denotes that no meta data has been associated with the
  namespaces in the mask [⊤] for the location [l].
- Meta data tokens can be split w.r.t. namespace masks, i.e.
  [meta_token l (E1 ∪ E2) ⊣⊢ meta_token l E1 ∗ meta_token l E2] if [E1 ## E2].
- Meta data can be set using the update [meta_token l E ==∗ meta l N x] provided
  [↑N ⊆ E], and [x : A] for any countable [A]. The [meta l N x] connective is
  persistent and denotes the knowledge that the meta data [x] has been
  associated with namespace [N] to the location [l].

To make the mechanism as flexible as possible, the [x : A] in [meta l N x] can
be of any countable type [A]. This means that you can associate e.g. single
ghost names, but also tuples of ghost names, etc.

To further increase flexibility, the [meta l N x] and [meta_token l E]
connectives are annotated with a namespace [N] and mask [E]. That way, one can
assign a map of meta information to a location. This is particularly useful when
building abstractions, then one can gradually assign more ghost information to a
location instead of having to do all of this at once. We use namespaces so that
these can be matched up with the invariant namespaces. *)

(** To implement this mechanism, we use three resource algebras:

- A [gmap_view L V], which keeps track of the values of locations.
- A [gmap_view L gname], which keeps track of the meta information of
  locations. More specifically, this RA introduces an indirection: it keeps
  track of a ghost name for each location.
- The ghost names in the aforementioned authoritative RA refer to namespace maps
  [reservation_map (agree positive)], which store the actual meta information.
  This indirection is needed because we cannot perform frame preserving updates
  in an authoritative fragment without owning the full authoritative element
  (in other words, without the indirection [meta_set] would need [gen_heap_interp]
  as a premise).
 *)

(** The CMRAs we need, and the global ghost names we are using. *)

Class gen_heapPreG (L V : Type) (Σ : gFunctors) `{Countable L} := {
  gen_heap_preG_inG :> ghost_mapG Σ L V;
  gen_meta_preG_inG :> ghost_mapG Σ L gname;
  gen_meta_data_preG_inG :> inG Σ (reservation_mapR (agreeR positiveO));
}.

Class gen_heapG (L V : Type) (Σ : gFunctors) `{Countable L} := GenHeapG {
  gen_heap_inG :> gen_heapPreG L V Σ;
  gen_heap_name : gname;
  gen_meta_name : gname
}.
Global Arguments GenHeapG L V Σ {_ _ _} _ _.
Global Arguments gen_heap_name {L V Σ _ _} _ : assert.
Global Arguments gen_meta_name {L V Σ _ _} _ : assert.

Definition gen_heapΣ (L V : Type) `{Countable L} : gFunctors := #[
  ghost_mapΣ L V;
  ghost_mapΣ L gname;
  GFunctor (reservation_mapR (agreeR positiveO))
].

Global Instance subG_gen_heapPreG {Σ L V} `{Countable L} :
  subG (gen_heapΣ L V) Σ → gen_heapPreG L V Σ.
Proof. solve_inG. Qed.

Section definitions.
  Context `{Countable L, hG : !gen_heapG L V Σ}.

  Definition gen_heap_interp (σ : gmap L V) : iProp Σ := ∃ m : gmap L gname,
    (* The [⊆] is used to avoid assigning ghost information to the locations in
    the initial heap (see [gen_heap_init]). *)
    ⌜ dom _ m ⊆ dom (gset L) σ ⌝ ∗
    ghost_map_auth (gen_heap_name hG) 1 σ ∗
    ghost_map_auth (gen_meta_name hG) 1 m.

  Definition mapsto_def (l : L) (dq : dfrac) (v: V) : iProp Σ :=
    l ↪[gen_heap_name hG]{dq} v.
  Definition mapsto_aux : seal (@mapsto_def). Proof. by eexists. Qed.
  Definition mapsto := mapsto_aux.(unseal).
  Definition mapsto_eq : @mapsto = @mapsto_def := mapsto_aux.(seal_eq).

  Definition meta_token_def (l : L) (E : coPset) : iProp Σ :=
    ∃ γm, l ↪[gen_meta_name hG]□ γm ∗ own γm (reservation_map_token E).
  Definition meta_token_aux : seal (@meta_token_def). Proof. by eexists. Qed.
  Definition meta_token := meta_token_aux.(unseal).
  Definition meta_token_eq : @meta_token = @meta_token_def := meta_token_aux.(seal_eq).

  (** TODO: The use of [positives_flatten] violates the namespace abstraction
  (see the proof of [meta_set]. *)
  Definition meta_def `{Countable A} (l : L) (N : namespace) (x : A) : iProp Σ :=
    ∃ γm, l ↪[gen_meta_name hG]□ γm ∗
          own γm (reservation_map_data (positives_flatten N) (to_agree (encode x))).
  Definition meta_aux : seal (@meta_def). Proof. by eexists. Qed.
  Definition meta := meta_aux.(unseal).
  Definition meta_eq : @meta = @meta_def := meta_aux.(seal_eq).
End definitions.
Global Arguments meta {L _ _ V Σ _ A _ _} l N x.

(** FIXME: Refactor these notations using custom entries once Coq bug #13654
has been fixed. *)
Local Notation "l ↦{ dq } v" := (mapsto l dq v)
  (at level 20, format "l  ↦{ dq }  v") : bi_scope.
Local Notation "l ↦□ v" := (mapsto l DfracDiscarded v)
  (at level 20, format "l  ↦□  v") : bi_scope.
Local Notation "l ↦{# q } v" := (mapsto l (DfracOwn q) v)
  (at level 20, format "l  ↦{# q }  v") : bi_scope.
Local Notation "l ↦ v" := (mapsto l (DfracOwn 1) v)
  (at level 20, format "l  ↦  v") : bi_scope.

Section gen_heap.
  Context {L V} `{Countable L, !gen_heapG L V Σ}.
  Implicit Types P Q : iProp Σ.
  Implicit Types Φ : V → iProp Σ.
  Implicit Types σ : gmap L V.
  Implicit Types m : gmap L gname.
  Implicit Types l : L.
  Implicit Types v : V.

  (** General properties of mapsto *)
  Global Instance mapsto_timeless l dq v : Timeless (l ↦{dq} v).
  Proof. rewrite mapsto_eq. apply _. Qed.
  Global Instance mapsto_fractional l v : Fractional (λ q, l ↦{#q} v)%I.
  Proof. rewrite mapsto_eq. apply _. Qed.
  Global Instance mapsto_as_fractional l q v :
    AsFractional (l ↦{#q} v) (λ q, l ↦{#q} v)%I q.
  Proof. rewrite mapsto_eq. apply _. Qed.
  Global Instance mapsto_persistent l v : Persistent (l ↦□ v).
  Proof. rewrite mapsto_eq. apply _. Qed.

  Lemma mapsto_valid l dq v : l ↦{dq} v -∗ ⌜✓ dq⌝%Qp.
  Proof. rewrite mapsto_eq. apply ghost_map_elem_valid. Qed.
  Lemma mapsto_valid_2 l dq1 dq2 v1 v2 : l ↦{dq1} v1 -∗ l ↦{dq2} v2 -∗ ⌜✓ (dq1 ⋅ dq2) ∧ v1 = v2⌝.
  Proof. rewrite mapsto_eq. apply ghost_map_elem_valid_2. Qed.
  (** Almost all the time, this is all you really need. *)
  Lemma mapsto_agree l dq1 dq2 v1 v2 : l ↦{dq1} v1 -∗ l ↦{dq2} v2 -∗ ⌜v1 = v2⌝.
  Proof. rewrite mapsto_eq. apply ghost_map_elem_agree. Qed.

  Lemma mapsto_combine l dq1 dq2 v1 v2 :
    l ↦{dq1} v1 -∗ l ↦{dq2} v2 -∗ l ↦{dq1 ⋅ dq2} v1 ∗ ⌜v1 = v2⌝.
  Proof. rewrite mapsto_eq. apply ghost_map_elem_combine. Qed.

  Lemma mapsto_frac_ne l1 l2 dq1 dq2 v1 v2 :
    ¬ ✓(dq1 ⋅ dq2) → l1 ↦{dq1} v1 -∗ l2 ↦{dq2} v2 -∗ ⌜l1 ≠ l2⌝.
  Proof. rewrite mapsto_eq. apply ghost_map_elem_frac_ne. Qed.
  Lemma mapsto_ne l1 l2 dq2 v1 v2 : l1 ↦ v1 -∗ l2 ↦{dq2} v2 -∗ ⌜l1 ≠ l2⌝.
  Proof. rewrite mapsto_eq. apply ghost_map_elem_ne. Qed.

  (** Permanently turn any points-to predicate into a persistent
      points-to predicate. *)
  Lemma mapsto_persist l dq v : l ↦{dq} v ==∗ l ↦□ v.
  Proof. rewrite mapsto_eq. apply ghost_map_elem_persist. Qed.

  (** General properties of [meta] and [meta_token] *)
  Global Instance meta_token_timeless l N : Timeless (meta_token l N).
  Proof. rewrite meta_token_eq. apply _. Qed.
  Global Instance meta_timeless `{Countable A} l N (x : A) : Timeless (meta l N x).
  Proof. rewrite meta_eq. apply _. Qed.
  Global Instance meta_persistent `{Countable A} l N (x : A) : Persistent (meta l N x).
  Proof. rewrite meta_eq. apply _. Qed.

  Lemma meta_token_union_1 l E1 E2 :
    E1 ## E2 → meta_token l (E1 ∪ E2) -∗ meta_token l E1 ∗ meta_token l E2.
  Proof.
    rewrite meta_token_eq /meta_token_def. intros ?. iDestruct 1 as (γm1) "[#Hγm Hm]".
    rewrite reservation_map_token_union //. iDestruct "Hm" as "[Hm1 Hm2]".
    iSplitL "Hm1"; eauto.
  Qed.
  Lemma meta_token_union_2 l E1 E2 :
    meta_token l E1 -∗ meta_token l E2 -∗ meta_token l (E1 ∪ E2).
  Proof.
    rewrite meta_token_eq /meta_token_def.
    iDestruct 1 as (γm1) "[#Hγm1 Hm1]". iDestruct 1 as (γm2) "[#Hγm2 Hm2]".
    iDestruct (ghost_map_elem_valid_2 with "Hγm1 Hγm2") as %[_ ->].
    iDestruct (own_valid_2 with "Hm1 Hm2") as %?%reservation_map_token_valid_op.
    iExists γm2. iFrame "Hγm2". rewrite reservation_map_token_union //. by iSplitL "Hm1".
  Qed.
  Lemma meta_token_union l E1 E2 :
    E1 ## E2 → meta_token l (E1 ∪ E2) ⊣⊢ meta_token l E1 ∗ meta_token l E2.
  Proof.
    intros; iSplit; first by iApply meta_token_union_1.
    iIntros "[Hm1 Hm2]". by iApply (meta_token_union_2 with "Hm1 Hm2").
  Qed.

  Lemma meta_token_difference l E1 E2 :
    E1 ⊆ E2 → meta_token l E2 ⊣⊢ meta_token l E1 ∗ meta_token l (E2 ∖ E1).
  Proof.
    intros. rewrite {1}(union_difference_L E1 E2) //.
    by rewrite meta_token_union; last set_solver.
  Qed.

  Lemma meta_agree `{Countable A} l i (x1 x2 : A) :
    meta l i x1 -∗ meta l i x2 -∗ ⌜x1 = x2⌝.
  Proof.
    rewrite meta_eq /meta_def.
    iDestruct 1 as (γm1) "[Hγm1 Hm1]"; iDestruct 1 as (γm2) "[Hγm2 Hm2]".
    iDestruct (ghost_map_elem_valid_2 with "Hγm1 Hγm2") as %[_ ->].
    iDestruct (own_valid_2 with "Hm1 Hm2") as %Hγ; iPureIntro.
    move: Hγ. rewrite -reservation_map_data_op reservation_map_data_valid.
    move=> /to_agree_op_inv_L. naive_solver.
  Qed.
  Lemma meta_set `{Countable A} E l (x : A) N :
    ↑ N ⊆ E → meta_token l E ==∗ meta l N x.
  Proof.
    rewrite meta_token_eq meta_eq /meta_token_def /meta_def.
    iDestruct 1 as (γm) "[Hγm Hm]". iExists γm. iFrame "Hγm".
    iApply (own_update with "Hm").
    apply reservation_map_alloc; last done.
    cut (positives_flatten N ∈@{coPset} ↑N); first by set_solver.
    rewrite nclose_eq. apply elem_coPset_suffixes.
    exists 1%positive. by rewrite left_id_L.
  Qed.

  (** Update lemmas *)
  Lemma gen_heap_alloc σ l v :
    σ !! l = None →
    gen_heap_interp σ ==∗ gen_heap_interp (<[l:=v]>σ) ∗ l ↦ v ∗ meta_token l ⊤.
  Proof.
    iIntros (Hσl). rewrite /gen_heap_interp mapsto_eq /mapsto_def meta_token_eq /meta_token_def /=.
    iDestruct 1 as (m Hσm) "[Hσ Hm]".
    iMod (ghost_map_insert l with "Hσ") as "[Hσ Hl]"; first done.
    iMod (own_alloc (reservation_map_token ⊤)) as (γm) "Hγm".
    { apply reservation_map_token_valid. }
    iMod (ghost_map_insert_persist l with "Hm") as "[Hm Hlm]".
    { move: Hσl. rewrite -!(not_elem_of_dom (D:=gset L)). set_solver. }
    iModIntro. iFrame "Hl". iSplitL "Hσ Hm"; last by eauto with iFrame.
    iExists (<[l:=γm]> m). iFrame. iPureIntro.
    rewrite !dom_insert_L. set_solver.
  Qed.

  Lemma gen_heap_alloc_big σ σ' :
    σ' ##ₘ σ →
    gen_heap_interp σ ==∗
    gen_heap_interp (σ' ∪ σ) ∗ ([∗ map] l ↦ v ∈ σ', l ↦ v) ∗ ([∗ map] l ↦ _ ∈ σ', meta_token l ⊤).
  Proof.
    revert σ; induction σ' as [| l v σ' Hl IH] using map_ind; iIntros (σ Hdisj) "Hσ".
    { rewrite left_id_L. auto. }
    iMod (IH with "Hσ") as "[Hσ'σ Hσ']"; first by eapply map_disjoint_insert_l.
    decompose_map_disjoint.
    rewrite !big_opM_insert // -insert_union_l //.
    by iMod (gen_heap_alloc with "Hσ'σ") as "($ & $ & $)";
      first by apply lookup_union_None.
  Qed.

  Lemma gen_heap_valid σ l dq v : gen_heap_interp σ -∗ l ↦{dq} v -∗ ⌜σ !! l = Some v⌝.
  Proof.
    iDestruct 1 as (m Hσm) "[Hσ _]". iIntros "Hl".
    rewrite /gen_heap_interp mapsto_eq.
    by iDestruct (ghost_map_lookup with "Hσ Hl") as %?.
  Qed.

  Lemma gen_heap_update σ l v1 v2 :
    gen_heap_interp σ -∗ l ↦ v1 ==∗ gen_heap_interp (<[l:=v2]>σ) ∗ l ↦ v2.
  Proof.
    iDestruct 1 as (m Hσm) "[Hσ Hm]".
    iIntros "Hl". rewrite /gen_heap_interp mapsto_eq /mapsto_def.
    iDestruct (ghost_map_lookup with "Hσ Hl") as %Hl.
    iMod (ghost_map_update with "Hσ Hl") as "[Hσ Hl]".
    iModIntro. iFrame "Hl". iExists m. iFrame.
    iPureIntro. apply (elem_of_dom_2 (D:=gset L)) in Hl.
    rewrite dom_insert_L. set_solver.
  Qed.
End gen_heap.

(** This variant of [gen_heap_init] should only be used when absolutely needed.
The key difference to [gen_heap_init] is that the [inG] instances in the new
[gen_heapG] instance are related to the original [gen_heapPreG] instance,
whereas [gen_heap_init] forgets about that relation. *)
Lemma gen_heap_init_names `{Countable L, !gen_heapPreG L V Σ} σ :
  ⊢ |==> ∃ γh γm : gname,
    let hG := GenHeapG L V Σ γh γm in
    gen_heap_interp σ ∗ ([∗ map] l ↦ v ∈ σ, l ↦ v) ∗ ([∗ map] l ↦ _ ∈ σ, meta_token l ⊤).
Proof.
  iMod (ghost_map_alloc_empty (K:=L) (V:=V)) as (γh) "Hh".
  iMod (ghost_map_alloc_empty (K:=L) (V:=gname)) as (γm) "Hm".
  iExists γh, γm.
  iAssert (gen_heap_interp (hG:=GenHeapG _ _ _ γh γm) ∅) with "[Hh Hm]" as "Hinterp".
  { iExists ∅; simpl. iFrame "Hh Hm". by rewrite dom_empty_L. }
  iMod (gen_heap_alloc_big with "Hinterp") as "(Hinterp & $ & $)".
  { apply map_disjoint_empty_r. }
  rewrite right_id_L. done.
Qed.

Lemma gen_heap_init `{Countable L, !gen_heapPreG L V Σ} σ :
  ⊢ |==> ∃ _ : gen_heapG L V Σ,
    gen_heap_interp σ ∗ ([∗ map] l ↦ v ∈ σ, l ↦ v) ∗ ([∗ map] l ↦ _ ∈ σ, meta_token l ⊤).
Proof.
  iMod (gen_heap_init_names σ) as (γh γm) "Hinit".
  iExists (GenHeapG _ _ _ γh γm).
  done.
Qed.


(*
 * Copyright (c) Meta Platforms, Inc. and affiliates.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the root directory of this source tree.
 *)
From stdpp Require Import base strings gmap stringmap fin_maps list.
(* Not using iris but importing their ssreflect dependencies *)
From iris.proofmode Require Import tactics.
From shack Require Import lang progdef.

(* Abstract definition of the SDT constraints at the class level. *)
Class SDTClassConstraints := {
  Δsdt : tag → list constraint;
  Δsdt_m : tag → string → list constraint;
}.

Section Subtype.
  (* assume a given set of class definitions *)
  Context `{PDC: ProgDefContext}.
  (* That are not cyclic *)
  Context `{PDA: ProgDefAcc}.
  (* assume some SDT constraints *)
  Context `{SDTCC: SDTClassConstraints}.

  Inductive subtype_kind := Aware | Plain.

  (* Type well-formdness is mostly introduced to be able to define
   * subtyping rule correctly, like unions.
   *)
  Inductive subtype (Δ : list constraint) : subtype_kind → lang_ty → lang_ty → Prop :=
    | SubMixed: ∀ kd ty, subtype Δ kd ty MixedT
    | SubNothing: ∀ kd ty, wf_ty ty → subtype Δ kd NothingT ty
    | SubClass: ∀ kd A σA B σB adef,
        pdefs !! A = Some adef →
        length σA = length adef.(generics) →
        extends_using A B σB →
        subtype Δ kd (ClassT false A σA) (ClassT false B (subst_ty σA <$> σB))
    | SubExact: ∀ kd A σA adef,
        pdefs !! A = Some adef →
        length σA = length adef.(generics) →
        subtype Δ kd (ClassT true A σA) (ClassT false A σA)
    | SubVariance: ∀ kd A adef σ0 σ1,
        pdefs !! A = Some adef →
        Forall wf_ty σ1 →
        subtype_targs Δ kd adef.(generics) σ0 σ1 →
        subtype Δ kd (ClassT false A σ0) (ClassT false A σ1)
    | SubExactVariance: ∀ kd A adef σ0 σ1,
        pdefs !! A = Some adef →
        Forall wf_ty σ1 →
        subtype_targs Δ kd ((λ _, Invariant) <$> adef.(generics)) σ0 σ1 →
        subtype Δ kd (ClassT true A σ0) (ClassT true A σ1)
    | SubMixed2 kd: subtype Δ kd MixedT (UnionT NonNullT NullT)
    | SubIntNonNull kd: subtype Δ kd IntT NonNullT
    | SubBoolNonNull kd: subtype Δ kd BoolT NonNullT
    | SubIntBoolDisj kd: subtype Δ kd (InterT IntT BoolT) NothingT
    | SubClassNonNull: ∀ kd exact A targs, subtype Δ kd (ClassT exact A targs) NonNullT
    | SubUnionUpper1: ∀ kd s t, wf_ty t → subtype Δ kd s (UnionT s t)
    | SubUnionUpper2: ∀ kd s t, wf_ty s → subtype Δ kd t (UnionT s t)
    | SubUnionLower : ∀ kd s t u, subtype Δ kd s u → subtype Δ kd t u → subtype Δ kd (UnionT s t) u
    | SubInterLower1: ∀ kd s t, subtype Δ kd (InterT s t) s
    | SubInterLower2: ∀ kd s t, subtype Δ kd (InterT s t) t
    | SubInterUpper: ∀ kd s t u, subtype Δ kd u s → subtype Δ kd u t → subtype Δ kd u (InterT s t)
    | SubRefl: ∀ kd s, subtype Δ kd s s
    | SubTrans: ∀ kd s t u, subtype Δ kd s t → subtype Δ kd t u → subtype Δ kd s u
    | SubConstraint: ∀ kd s t, (s, t) ∈ Δ → subtype Δ kd s t
    | SubClassDyn: ∀ kd exact A adef σA,
        pdefs !! A = Some adef →
        wf_ty (ClassT exact A σA) →
        (* Δ => Δsdt,A[σA] *)
        (∀ k s t, (subst_constraints σA (Δsdt A)) !! k = Some (s, t) → subtype Δ kd s t) →
        (* Δ => ΔA[σA] *)
        (∀ k s t, adef.(constraints) !! k = Some (s, t) → subtype Δ kd (subst_ty σA s) (subst_ty σA t)) →
        subtype Δ kd (ClassT exact A σA) SupportDynT
    | SubIntDyn kd: subtype Δ kd IntT SupportDynT
    | SubBoolDyn kd: subtype Δ kd BoolT SupportDynT
    | SubNullDyn kd: subtype Δ kd NullT SupportDynT
    | SubSupDyn: subtype Δ Aware SupportDynT DynamicT
    | SubDynPrim kd : subtype Δ kd DynamicT SupportDynT
    | SubFalse kd : ∀ A B,
        wf_ty B →
        subtype Δ kd IntT BoolT →
        subtype Δ kd A B
  with subtype_targs (Δ: list constraint) : subtype_kind → list variance → list lang_ty → list lang_ty → Prop :=
    | subtype_targs_nil kd: subtype_targs Δ kd [] [] []
    | subtype_targs_invariant: ∀ kd ty0 ty1 vs ty0s ty1s,
        subtype Δ kd ty0 ty1 →
        subtype Δ kd ty1 ty0 →
        subtype_targs Δ kd vs ty0s ty1s →
        subtype_targs Δ kd (Invariant :: vs) (ty0 :: ty0s) ( ty1 :: ty1s)
    | subtype_targs_covariant: ∀ kd ty0 ty1 vs ty0s ty1s,
        subtype Δ kd ty0 ty1 →
        subtype_targs Δ kd vs ty0s ty1s →
        subtype_targs Δ kd (Covariant :: vs) (ty0 :: ty0s) ( ty1 :: ty1s)
    | subtype_targs_contravariant: ∀ kd ty0 ty1 vs ty0s ty1s,
        subtype Δ kd ty1 ty0 →
        subtype_targs Δ kd vs ty0s ty1s →
        subtype_targs Δ kd (Contravariant :: vs) (ty0 :: ty0s) (ty1 :: ty1s)
  .

  Definition Δentails kd (Δ0 Δ1: list constraint) :=
    ∀ i c, Δ1 !! i = Some c → subtype Δ0 kd c.1 c.2.

  (* Properties of Δsdt *)
  Class SDTClassSpec `{PDA : ProgDefAcc} := {
    (* Δsdt preserves the wf_ty of σ *)
    Δsdt_wf: ∀ A k c, Δsdt A !! k = Some c -> wf_constraint c;
    Δsdt_m_wf: ∀ A m k c, Δsdt_m A m !! k = Some c -> wf_constraint c;
    (* Δsdt is bounded by the generics of its class *)
    Δsdt_bounded: ∀ A adef k c,
      pdefs !! A = Some adef →
      Δsdt A !! k = Some c →
      bounded_constraint (length adef.(generics)) c;
    Δsdt_m_bounded: ∀ A m adef k c,
      pdefs !! A = Some adef →
      Δsdt_m A m !! k = Some c →
      bounded_constraint (length adef.(generics)) c;
    (* Like normal constraints, Δsdt can't use the `this` type *)
    Δsdt_no_this: ∀ A k c, Δsdt A !! k = Some c -> no_this_constraint c;
    Δsdt_m_no_this: ∀ A m k c,
      Δsdt_m A m !! k = Some c →
      no_this_constraint c;
  }.
End Subtype.

Section SubtypeFacts.
  (* assume a given set of class definitions and
   * their SDT annotations.
   *)
  Context `{SDTCS: SDTClassSpec}.

  Corollary length_subtype_targs_v0 Δ kd: ∀ vs ty0s ty1s,
    subtype_targs Δ kd vs ty0s ty1s → length vs = length ty0s.
  Proof.
    induction 1 as [ | ???????? h hi | ??????? h hi | ??????? h hi] => //=; by rewrite hi.
  Qed.

  Corollary length_subtype_targs_v1 Δ kd: ∀ vs ty0s ty1s,
    subtype_targs Δ kd vs ty0s ty1s → length vs = length ty1s.
  Proof.
    induction 1 as [ | ???????? h hi | ??????? h hi | ??????? h hi] => //=; by rewrite hi.
  Qed.

  Hint Constructors subtype : core.
  Hint Constructors subtype_targs : core.

  Notation "Δ ⊢ s <: t" := (subtype Δ Plain s t) (at level 70, s at next level, no associativity).
  Notation "Δ ⊢ s <D: t" := (subtype Δ Aware s t) (at level 70, s at next level, no associativity).
  Notation "Δ ⊢ lts <: vs :> rts" := (subtype_targs Δ Plain vs lts rts) (at level 70, lts, vs at next level).

  Lemma subtype_to_Aware Δ kd s t : subtype Δ kd s t → subtype Δ Aware s t
  with subtype_targs_to_Aware Δ kd lhs vs rhs :
     subtype_targs Δ kd vs lhs rhs → subtype_targs Δ Aware vs lhs rhs.
  Proof.
    - destruct 1 as [ kd ty | kd ty hwf | kd A σA B σB adef hadef hL hext
      | kd A σA adef hadef hL
      | kd A adef σ0 σ1 hadef hwf hσ
      | kd A adef σ0 σ1 hadef hwf hσ
      | | | | | kd A targs
      | kd s t ht | kd s t hs | kd s t u hs ht | kd s t | kd s t | kd s t u hs ht
      | kd s | kd s t u hs ht | kd s t hin | kd ? A adef σA hpdefs hwfA hf0 hf1
      | | | | | | kd A B hwf h]; try by econstructor.
      + econstructor => //; by eapply subtype_targs_to_Aware.
      + econstructor => //; by eapply subtype_targs_to_Aware.
      + econstructor; by eapply subtype_to_Aware.
      + econstructor; by eapply subtype_to_Aware.
      + econstructor; by eapply subtype_to_Aware.
      + eapply SubClassDyn => //.
        * move => k s t hst.
          eapply subtype_to_Aware.
          by eapply hf0.
        * move => k s t hc.
          eapply subtype_to_Aware.
          by eapply hf1.
      + eapply SubFalse => //.
        by eapply subtype_to_Aware.
    - destruct 1 as [ | ???????? h | ??????? h | ??????? h ].
      + by constructor.
      + econstructor; [ by eapply subtype_to_Aware | by eapply subtype_to_Aware | ].
        by eapply subtype_targs_to_Aware.
      + econstructor; [ by eapply subtype_to_Aware | ].
        by eapply subtype_targs_to_Aware.
      + econstructor; [ by eapply subtype_to_Aware | ].
        by eapply subtype_targs_to_Aware.
  Qed.

  Lemma subtype_weaken Δ kd s t: subtype Δ kd s t → ∀ Δ', Δ ⊆ Δ' → subtype Δ' kd s t
   with subtype_targs_weaken Δ kd lhs vs rhs:
     subtype_targs Δ kd vs lhs rhs → ∀ Δ', Δ ⊆ Δ' → subtype_targs Δ' kd vs lhs rhs.
  Proof.
    - destruct 1 as [ kd ty | kd ty hwf | kd A σA B σB adef hadef hL hext
      | kd A adef σA hadef hL
      | kd A adef σ0 σ1 hadef hwf hσ
      | kd A adef σ0 σ1 hadef hwf hσ
      | | | | | kd A targs
      | kd s t ht | kd s t hs | kd s t u hs ht | kd s t | kd s t | kd s t u hs ht
      | kd s | kd s t u hs ht | kd s t hin | kd ? A adef σA hpdefs hwfA hf0 hf1
      | | | | | | kd A B hwf h] => Δ' hΔ; try by econstructor.
      + econstructor; [ done | done | ].
        by eapply subtype_targs_weaken.
      + econstructor; [ done | done | ].
        by eapply subtype_targs_weaken.
      + econstructor; by eapply subtype_weaken.
      + econstructor; by eapply subtype_weaken.
      + econstructor; by eapply subtype_weaken.
      + apply SubConstraint.
        by set_solver.
      + eapply SubClassDyn => // k s t hst.
        * eapply subtype_weaken; last done.
          by eapply hf0.
        * eapply subtype_weaken; last done.
          by eapply hf1.
      + eapply SubFalse => //.
        by eapply subtype_weaken.
    - destruct 1 as [ | ???????? h | ??????? h | ??????? h ] => Δ' hΔ.
      + by constructor.
      + econstructor; [ by eapply subtype_weaken | by eapply subtype_weaken | ].
        by eapply subtype_targs_weaken.
      + econstructor; [ by eapply subtype_weaken | ].
        by eapply subtype_targs_weaken.
      + econstructor; [ by eapply subtype_weaken | ].
        by eapply subtype_targs_weaken.
  Qed.

  Lemma subtype_constraint_elim_ G kd S T:
    subtype G kd S T →
    ∀ Δ Δ', G = Δ ++ Δ' →
    (∀ i c, Δ' !! i = Some c → subtype Δ kd c.1 c.2) →
    subtype Δ kd S T
  with subtype_targs_constraint_elim_ G kd lhs vs rhs:
    subtype_targs G kd vs lhs rhs →
    ∀ Δ Δ', G = Δ ++ Δ' →
    (∀ i c, Δ' !! i = Some c → subtype Δ kd c.1 c.2) →
    subtype_targs Δ kd vs lhs rhs.
  Proof.
    - destruct 1 as [ kd ty | kd ty hwf | kd A σA B σB adef hadef hL hext
      | kd A adef σA hadef hL
      | kd A adef σ0 σ1 hadef hwf hσ
      | kd A adef σ0 σ1 hadef hwf hσ
      | kd | kd | kd | kd |  kd A targs
      | kd s t ht | kd s t hs | kd s t u hs ht | kd s t | kd s t | kd s t u hs ht | kd s
      | kd s t u hs ht | kd s t hin | kd ? A adef σA hpdefs hwfA hf0 hf1
      | | | | | | kd A B hwf h ]
      => Δ Δ' heq hΔ; subst; try by econstructor.
      + econstructor; [done | done | ].
        by eapply subtype_targs_constraint_elim_.
      + econstructor; [done | done | ].
        by eapply subtype_targs_constraint_elim_.
      + econstructor; by eapply subtype_constraint_elim_.
      + econstructor; by eapply subtype_constraint_elim_.
      + econstructor; by eapply subtype_constraint_elim_.
      + apply elem_of_app in hin as [hin | hin].
        { by apply SubConstraint. }
        apply elem_of_list_lookup_1 in hin as [i hin].
        by apply hΔ in hin.
      + eapply SubClassDyn => // k s t hst.
        * eapply subtype_constraint_elim_; by eauto.
        * eapply subtype_constraint_elim_; by eauto.
      + eapply SubFalse => //.
        eapply subtype_constraint_elim_; by eauto.
    - destruct 1 as [ | ???????? h | ??????? h | ??????? h ] => Δ Δ' heq hΔ; subst.
      + by constructor.
      + econstructor; [ by eapply subtype_constraint_elim_ | by eapply subtype_constraint_elim_ | ].
        by eapply subtype_targs_constraint_elim_.
      + econstructor; [ by eapply subtype_constraint_elim_ | ].
        by eapply subtype_targs_constraint_elim_.
      + econstructor; [ by eapply subtype_constraint_elim_ | ].
        by eapply subtype_targs_constraint_elim_.
  Qed.

  Lemma subtype_constraint_elim kd Δ Δ' S T:
    subtype (Δ ++ Δ') kd  S T →
    (∀ i c, Δ' !! i = Some c → subtype Δ kd c.1 c.2) →
    subtype Δ kd S T.
  Proof. intros; by eapply subtype_constraint_elim_. Qed.

  Lemma subtype_constraint_trans Δ kd s t:
    subtype Δ kd s t →
    ∀ Δ', (∀ i c, Δ !! i = Some c → subtype Δ' kd c.1 c.2) →
    subtype Δ' kd s t
  with subtype_targs_constraint_trans Δ kd lhs vs rhs:
    subtype_targs Δ kd vs lhs rhs →
    ∀ Δ', (∀ i c, Δ !! i = Some c → subtype Δ' kd c.1 c.2) →
    subtype_targs Δ' kd vs lhs rhs.
  Proof.
    - destruct 1 as [ kd ty | kd ty hwf | kd A σA B σB adef hadef hL hext
      | kd A σA adef hadef hL
      | kd A adef σ0 σ1 hadef hwf hσ
      | kd A adef σ0 σ1 hadef hwf hσ
      | | | | | kd A targs
      | kd s t ht | kd s t hs | kd s t u hs ht | kd s t | kd s t | kd s t u hs ht
      | kd s | kd s t u hs ht | kd s t hin | kd ? A adef σA hpdefs hwfA hf0 hf1
      | | | | | | kd A B hwf h] => Δ' hΔ; try by econstructor.
      + eapply SubVariance; [exact hadef | assumption | ].
        eapply subtype_targs_constraint_trans.
        * by apply hσ.
        * exact hΔ.
      + eapply SubExactVariance; [exact hadef | assumption | ].
        eapply subtype_targs_constraint_trans.
        * by apply hσ.
        * exact hΔ.
      + econstructor; by eapply subtype_constraint_trans.
      + econstructor; by eapply subtype_constraint_trans.
      + apply SubTrans with t; by eapply subtype_constraint_trans.
      + apply elem_of_list_lookup in hin as [i hin].
        by apply hΔ in hin.
      + eapply SubClassDyn => // k s t hst.
        * eapply subtype_constraint_trans; by eauto.
        * eapply subtype_constraint_trans; by eauto.
      + eapply SubFalse => //.
        eapply subtype_constraint_trans; by eauto.
    - destruct 1 as [ | ???????? h | ??????? h | ??????? h ] => Δ' hΔ.
      + by constructor.
      + econstructor; [ by eapply subtype_constraint_trans | by eapply subtype_constraint_trans | ].
        by eapply subtype_targs_constraint_trans.
      + econstructor; [ by eapply subtype_constraint_trans | ].
        by eapply subtype_targs_constraint_trans.
      + econstructor; [ by eapply subtype_constraint_trans | ].
        by eapply subtype_targs_constraint_trans.
  Qed.

  (* See Andrew Kennedy's paper:
     Variance and Generalized Constraints for C♯ Generics
  *)
  Inductive mono (vs: list variance) : lang_ty → Prop :=
    | MonoInt : mono vs IntT
    | MonoBool : mono vs BoolT
    | MonoNothing : mono vs NothingT
    | MonoMixed : mono vs MixedT
    | MonoNull : mono vs NullT
    | MonoNonNull : mono vs NonNullT
    | MonoUnion s t : mono vs s → mono vs t → mono vs (UnionT s t)
    | MonoInter s t : mono vs s → mono vs t → mono vs (InterT s t)
    | MonoVInvGen n: vs !! n = Some Invariant → mono vs (GenT n)
    | MonoVCoGen n: vs !! n = Some Covariant → mono vs (GenT n)
    | MonoClass (exact:bool) cname cdef targs:
        pdefs !! cname = Some cdef →
        (∀ i wi ti, cdef.(generics) !! i = Some wi →
                    targs !! i = Some ti →
                    not_contra wi ∨ exact = true →
                    mono vs ti) →
        (∀ i wi ti, cdef.(generics) !! i = Some wi →
                    targs !! i = Some ti →
                    not_cov wi ∨ exact = true →
                    mono (neg_variance <$> vs) ti) →
        mono vs (ClassT exact cname targs)
    | MonoDynamic : mono vs DynamicT
    | MonoSupportDyn : mono vs SupportDynT
    | MonoThis : mono vs ThisT
  .

  Lemma monoI vs ty:
    mono vs ty →
    match ty with
    | ClassT exact t σ =>
        ∃ def, pdefs !! t = Some def ∧
        (∀ i wi ti, def.(generics) !! i = Some wi →
                    σ !! i = Some ti →
                    not_contra wi ∨ exact = true →
                    mono vs ti) ∧
        (∀ i wi ti, def.(generics) !! i = Some wi →
                    σ !! i = Some ti →
                    not_cov wi ∨ exact = true →
                    mono (neg_variance <$> vs) ti)
    | UnionT A B
    | InterT A B => mono vs A ∧ mono vs B
    | GenT n =>
        match vs !! n with
        | Some Invariant
        | Some Covariant => True
        | _ => False
        end
    | _ => True
    end.
  Proof.
    move => h; inv h; simplify_eq; try by eauto.
    - by rewrite H.
    - by rewrite H.
  Qed.

  Definition wf_cdef_mono cdef : Prop :=
    match cdef.(superclass) with
    | None => True
    | Some (parent, σ) =>
        mono cdef.(generics) (ClassT false parent σ)
    end
  .

  Definition wf_mdef_mono vs mdef : Prop :=
    match mdef.(methodvisibility) with
    | Private => True
    | Public =>
        map_Forall (λ _argname, mono (neg_variance <$> vs)) mdef.(methodargs) ∧
        mono vs mdef.(methodrettype)
    end.

  Definition wf_cdef_methods_mono cdef : Prop :=
   map_Forall (λ _mname, wf_mdef_mono cdef.(generics)) cdef.(classmethods)
  .

  Definition invariant vs ty :=
    mono vs ty ∧ mono (neg_variance <$> vs) ty.

  Definition field_mono vs (vfty: visibility * lang_ty) :=
    let (vis, fty) := vfty in
    match vis with
    | Public => invariant vs fty
    | Private => True
    end.

  Definition wf_field_mono cdef :=
    map_Forall (λ _fname, field_mono cdef.(generics)) cdef.(classfields).

  Lemma mono_subst vs ty:
    mono vs ty →
    bounded (length vs) ty →
    ∀ ws σ,
    length vs = length σ →
    (∀ i vi ti, vs !! i = Some vi → σ !! i = Some ti →
      not_cov vi → mono (neg_variance <$> ws) ti) →
    (∀ i vi ti, vs !! i = Some vi → σ !! i = Some ti →
      not_contra vi → mono ws ti) →
    mono ws (subst_ty σ ty).
  Proof.
    induction 1 as [ | | | | | | vs s t hs his ht hit
      | vs s t hs his ht hit | vs n hinv | vs n hco
      | vs exact_ cname cdef targs hpdefs hcov hicov hcontra hicontra | | | ]
      => hb ws σ hlen h0 h1 //=; try by constructor.
    - apply boundedI in hb as [??].
      constructor.
      + eapply his; by eauto.
      + eapply hit; by eauto.
    - apply boundedI in hb as [??].
      constructor.
      + eapply his; by eauto.
      + eapply hit; by eauto.
    - destruct (σ !! n) as [ty | ] eqn:hty => //=.
      + by eapply h1.
      + apply lookup_lt_Some in hinv.
        rewrite hlen in hinv.
        apply lookup_lt_is_Some_2 in hinv.
        rewrite hty in hinv.
        by elim hinv.
    - destruct (σ !! n) as [ty | ] eqn:hty => //=.
      + by eapply h1.
      + apply lookup_lt_Some in hco.
        rewrite hlen in hco.
        apply lookup_lt_is_Some_2 in hco.
        rewrite hty in hco.
        by elim hco.
    - apply boundedI in hb as hb.
      rewrite Forall_lookup in hb.
      econstructor; first done.
      + move => i ci ti hci hi hc.
        apply list_lookup_fmap_inv in hi as [ty [-> hi]].
        eapply hicov => //.
        by apply hb in hi.
      + move => i ci ti hci hi hc.
        apply list_lookup_fmap_inv in hi as [ty [-> hi]].
        eapply hicontra => //.
        * rewrite map_length.
          by apply hb in hi.
        * by rewrite map_length.
        * move => j vj tj hj htj hcj.
          apply list_lookup_fmap_inv in hj as [vj' [-> hj]].
          rewrite neg_variance_fmap_idem.
          eapply h1 => //.
          by destruct vj'.
        * move => j vj tj hj htj hcj.
          apply list_lookup_fmap_inv in hj as [vj' [-> hj]].
          eapply h0 => //.
          by destruct vj'.
  Qed.

  Lemma extends_using_mono A B σ :
    map_Forall (λ _cname, wf_cdef_mono) pdefs →
    extends_using A B σ →
    ∀ def, pdefs !! A = Some def →
    mono def.(generics) (ClassT false B σ).
  Proof.
    move => hmono h def hdef.
    destruct h as [A B adef σ hadef hsuper]; simplify_eq.
    apply hmono in hadef.
    by rewrite /wf_cdef_mono hsuper in hadef.
  Qed.

  Derive Inversion_clear mono_classI with
    (∀ vs ex t σ, mono vs (ClassT ex t σ)) Sort Prop.

  Lemma inherits_using_mono A B σ :
    map_Forall (λ _ : string, wf_cdef_parent) pdefs →
    map_Forall (λ _cname, wf_cdef_mono) pdefs →
    inherits_using A B σ →
    ∀ def, pdefs !! A = Some def →
    mono def.(generics) (ClassT false B σ).
  Proof.
    move => ? hmono.
    induction 1 as [A adef h | A B σ C σC hext h hi ] => def hdef.
    - simplify_eq.
      econstructor => //.
      + move => i wi ti hgi /lookup_gen_targs -> hc.
        case: hc => // hc.
        destruct wi; by constructor.
      + move => i wi ti hgi /lookup_gen_targs -> hc.
        case: hc => // hc.
        destruct wi => //.
        * apply MonoVInvGen.
          by rewrite list_lookup_fmap hgi.
        * apply MonoVCoGen.
          by rewrite list_lookup_fmap hgi.
    - apply inherits_using_wf in h => //.
      destruct h as (bdef & hbdef & hF & hwf).
      assert (hbdef' := hbdef).
      assert (hext' := hext).
      apply hi in hbdef.
      apply extends_using_mono with (def := def) in hext' => //.
      elim/mono_classI : hext'.
      move => ?? hnotcontra hnotcov; simplify_eq.
      change (ClassT false C (subst_ty σ <$> σC)) with (subst_ty σ (ClassT false C σC)).
      apply mono_subst with (generics bdef) => //.
      + by constructor.
      + apply extends_using_wf in hext => //.
        destruct hext as (? & ? & ? & hwfB & _).
        apply wf_tyI in hwfB as (? & ? & hlen & ?); simplify_eq.
        by rewrite hlen.
      + intros; by firstorder.
      + intros; by firstorder.
  Qed.

  Lemma has_field_mono f t vis ty orig:
    map_Forall (λ _cname, wf_field_mono) pdefs →
    map_Forall (λ _cname, wf_cdef_mono) pdefs →
    map_Forall (λ _cname, wf_cdef_parent) pdefs →
    map_Forall (λ _cname, wf_cdef_fields_bounded) pdefs →
    has_field f t vis ty orig →
    ∃ def, pdefs !! t = Some def ∧
    match vis with
    | Public => invariant def.(generics) ty
    | Private => True
    end.
  Proof.
    move => hwfpdefs hmono hp hfb.
    induction 1 as [ tag tdef [vis typ] htdef hf
      | tag targs parent tdef vis typ orig htdef hf hs h hi ].
      - exists tdef; split => //.
        apply hwfpdefs in htdef.
        by apply htdef in hf.
      - destruct hi as [def [hdef hvis]].
        exists tdef; split => //.
        destruct vis; last done.
        destruct hvis as [h0 h1].
        assert (htag := htdef).
        apply hp in htag.
        rewrite /wf_cdef_parent hs in htag.
        destruct htag as (hwf & hf0); simplify_eq.
        apply wf_tyI in hwf as (def' & hdef' & ? & ?); simplify_eq.
        apply has_field_bounded in h => //.
        destruct h as (pdef & ? & hbt).
        assert (htag := htdef).
        apply hmono in htag.
        rewrite /wf_cdef_mono hs in htag.
        elim/mono_classI: htag.
        move => ?? hnotcontra hnotcov; simplify_eq.
        split.
        + apply mono_subst with (generics pdef) => //.
          * intros; by firstorder.
          * intros; by firstorder.
        + apply mono_subst with (neg_variance <$> generics pdef) => //.
          * by rewrite map_length.
          * by rewrite map_length.
          * rewrite !neg_variance_fmap_idem.
            move => i vi ti hvi hti hc.
            apply list_lookup_fmap_inv in hvi.
            destruct hvi as [wi [-> hwi]].
            eapply hnotcontra => //.
            left.
            by destruct wi.
          * move => i vi ti hvi hti hc.
            apply list_lookup_fmap_inv in hvi.
            destruct hvi as [wi [-> hwi]].
            eapply hnotcov => //.
            left.
            by destruct wi.
  Qed.

  Lemma subtype_wf Δ kd A B:
    map_Forall (λ _cname, wf_cdef_parent) pdefs →
    Forall wf_constraint Δ →
    wf_ty A → subtype Δ kd A B → wf_ty B.
  Proof.
    move => hp hΔ hwf.
    induction 1 as [ kd ty | kd ty h | kd A σA B σB adef hadef hA hext
      | kd A σA adef hadef hL
      | kd A adef σ0 σ1 hadef hwfσ hσ
      | kd A adef σ0 σ1 hadef hwfσ hσ
      | | | | | kd A args | kd s t h
      | kd s t h | kd s t u hs his ht hit | kd s t | kd s t | kd s t u hs his ht hit | kd s
      | kd s t u hst hist htu hitu | kd s t hin | kd ? A adef σA hwfA hadef hf hi
      | | | | | | kd A B ? h hi ]
      => //=; try (by constructor).
    - destruct hext as [A B adef' σB hadef' hsuper]; simplify_eq.
      rewrite /map_Forall_lookup in hp.
      apply hp in hadef.
      rewrite /wf_cdef_parent hsuper in hadef.
      destruct hadef as (hwfB & hF).
      apply wf_tyI in hwfB as (? & ? & ? & hwfB).
      econstructor; first done.
      + by rewrite map_length.
      + rewrite Forall_lookup => k ty.
        rewrite list_lookup_fmap.
        destruct (σB !! k) as [ tyk | ] eqn:hty => //=.
        case => <-.
        apply wf_ty_subst; first by apply wf_ty_classI in hwf.
        rewrite Forall_lookup in hwfB.
        by eauto.
    - apply wf_tyI in hwf as [? [? [??]]]; simplify_eq; by econstructor.
    - apply length_subtype_targs_v1 in hσ.
      apply wf_tyI in hwf as [? [hadef' [? hwf0]]]; simplify_eq; econstructor.
      + exact hadef'.
      + by rewrite hσ.
      + rewrite Forall_lookup => k ty hty.
        rewrite !Forall_lookup in hwfσ, hwf0.
        by eauto.
    - apply length_subtype_targs_v1 in hσ.
      apply wf_tyI in hwf as [? [hadef' [? hwf0]]]; simplify_eq; econstructor.
      + exact hadef'.
      + by rewrite -hσ fmap_length.
      + rewrite Forall_lookup => k ty hty.
        rewrite !Forall_lookup in hwfσ, hwf0.
        by eauto.
    - apply wf_tyI in hwf as [??]; by eauto.
    - apply wf_tyI in hwf as [??]; by eauto.
    - apply wf_tyI in hwf as [??]; by eauto.
    - constructor; by eauto.
    - by eauto.
    - rewrite Forall_forall in hΔ.
      by apply hΔ in hin as [].
  Qed.

  Lemma subtype_subst Δ kd A B:
    map_Forall (λ _cname, wf_cdef_parent) pdefs →
    map_Forall (λ _, wf_cdef_constraints_bounded) pdefs →
    subtype Δ kd A B → ∀ σ,
    Forall wf_ty σ →
    subtype (subst_constraints σ Δ) kd (subst_ty σ A) (subst_ty σ B)
  with subtype_targs_subst Δ kd vs As Bs:
    map_Forall (λ _cname, wf_cdef_parent) pdefs →
    map_Forall (λ _, wf_cdef_constraints_bounded) pdefs →
    subtype_targs Δ kd vs As Bs → ∀ σ,
    Forall wf_ty σ →
    subtype_targs (subst_constraints σ Δ) kd vs (subst_ty σ <$> As) (subst_ty σ <$> Bs).
  Proof.
    - move => hp hb.
      destruct 1 as [ kd ty | kd ty h | kd A σA B σB adef hadef hA hext
      | kd A σA adef hadef hL
      | kd A adef σ0 σ1 hadef hwfσ hσ01
      | kd A adef σ0 σ1 hadef hwfσ hσ01
      | | | | | kd A args
      | kd s t h | kd s t h | kd s t u hs ht | kd s t | kd s t | kd s t u hs ht | kd s
      | kd s t u hst htu | kd s t hin | kd ? A adef σA hadef hwfA hf0 hf1
      | | | | | | kd A B hwf h ]
      => σ hσ => /=; try (by constructor).
      + constructor.
        by apply wf_ty_subst.
      + rewrite map_subst_ty_subst.
        * econstructor; [exact hadef | | by assumption].
          by rewrite map_length.
        * apply extends_using_wf in hext; last done.
          destruct hext as (? & hadef' & hF & hwfB & _).
          apply wf_tyI in hwfB as [? [? [??]]]; simplify_eq.
          by rewrite hA.
      + eapply SubExact => //.
        by rewrite fmap_length.
      + eapply SubVariance.
        * exact hadef.
        * rewrite Forall_forall => ty /elem_of_list_fmap [ty' [-> hin]].
          apply wf_ty_subst => //.
          rewrite Forall_forall in hwfσ; by apply hwfσ in hin.
        * apply subtype_targs_subst; by assumption.
      + eapply SubExactVariance.
        * exact hadef.
        * rewrite Forall_forall => ty /elem_of_list_fmap [ty' [-> hin]].
          apply wf_ty_subst => //.
          rewrite Forall_forall in hwfσ; by apply hwfσ in hin.
        * apply subtype_targs_subst; by assumption.
      + constructor.
        by apply wf_ty_subst.
      + constructor.
        by apply wf_ty_subst.
      + constructor; by apply subtype_subst.
      + constructor; by apply subtype_subst.
      + econstructor; by apply subtype_subst.
      + apply SubConstraint.
        apply elem_of_list_lookup_1 in hin as [i hin].
        apply elem_of_list_lookup; exists i.
        by rewrite /subst_constraints list_lookup_fmap hin.
      + eapply SubClassDyn => //.
        * apply wf_tyI in hwfA as [? [? [? hwf]]]; simplify_eq.
          rewrite Forall_lookup in hwf.
          econstructor => //.
          { by rewrite fmap_length. }
          rewrite Forall_lookup  => k ty h.
          apply list_lookup_fmap_inv in h as [? [-> h]].
          apply wf_ty_subst => //.
          by eauto.
        * move => k s t hst.
          apply list_lookup_fmap_inv in hst as [[u v] [[= -> ->] h]].
          assert (hbst: bounded_constraint (length σA) (u, v)).
          { apply wf_tyI in hwfA as [? [? [hlen ?]]]; simplify_eq.
            rewrite hlen; by eapply Δsdt_bounded in h.
          }
          destruct hbst as [].
          rewrite -!subst_ty_subst //.
          eapply subtype_subst; [done | done | | done].
          apply hf0 with k.
          by rewrite /subst_constraints list_lookup_fmap h.
        * move => k s t hst.
          assert (hbst: bounded_constraint (length σA) (s, t)).
          { apply wf_tyI in hwfA as [? [? [hlen ?]]]; simplify_eq.
            apply hb in hadef.
            rewrite /wf_cdef_constraints_bounded Forall_lookup in hadef.
            apply hadef in hst.
            by rewrite hlen.
          }
          destruct hbst as [].
          rewrite -!subst_ty_subst //.
          eapply subtype_subst; [done | done | | done].
          by eapply hf1.
      + eapply SubFalse.
        * by apply wf_ty_subst.
        * change IntT with (subst_ty σ IntT).
          change BoolT with (subst_ty σ BoolT).
          by eapply subtype_subst.
    - move => hp hb.
      destruct 1 as [ | ?????? h0 h1 h | ?????? h0 h | ?????? h0 h] => σ hσ /=.
      + by constructor.
      + constructor.
        * by apply subtype_subst.
        * by apply subtype_subst.
        * by apply subtype_targs_subst.
      + constructor.
        * by apply subtype_subst.
        * by apply subtype_targs_subst.
      + constructor.
        * by apply subtype_subst.
        * by apply subtype_targs_subst.
  Qed.

  (* Sanity checks: Some derived rules *)
  Lemma subtype_union_comm Δ: ∀ A B,
    wf_ty A → wf_ty B →
    Δ ⊢ (UnionT A B) <: (UnionT B A).
  Proof. by auto. Qed.

  Lemma subtype_inter_comm Δ : ∀ A B,
    wf_ty A → wf_ty B →
    Δ ⊢ (InterT A B) <: (InterT B A).
  Proof. by auto. Qed.

  Lemma subtype_union_assoc Δ:
    ∀ A B C,
    wf_ty A → wf_ty B → wf_ty C →
    Δ ⊢ (UnionT (UnionT A B) C) <: (UnionT A (UnionT B C)).
  Proof.
    move => A B C wfA wfB wfC.
    apply SubUnionLower; last by eauto.
    apply SubUnionLower; last by eauto.
    apply SubUnionUpper1.
    constructor; by eauto.
  Qed.

  Lemma subtype_inter_assoc Δ:
    ∀ A B C,
    wf_ty A → wf_ty B → wf_ty C →
    Δ ⊢ (InterT (InterT A B) C) <: (InterT A (InterT B C)).
  Proof. by eauto. Qed.

  Lemma Δentails_app kd Δ0 Δ1:
    Δentails kd Δ0 Δ1 → ∀ Δ, Δentails kd (Δ ++ Δ0) (Δ ++ Δ1).
  Proof.
    move => hΔ01 Δ k [s t] /=.
    rewrite lookup_app.
    destruct (Δ !! k) as [[s0 t0] | ] eqn:h0; rewrite h0 /=.
    - case => <- <-.
      eapply SubConstraint.
      apply elem_of_list_lookup_2 in h0.
      by set_solver.
    - move => h1.
      apply hΔ01 in h1.
      eapply subtype_weaken with Δ0 => //.
      by set_solver.
  Qed.

  (* Typing contexts *)
  Definition local_tys := stringmap lang_ty.

  (* Subtype / Inclusion of typing contexts *)
  Definition lty_sub Δ kd (Γ0 Γ1: local_tys) :=
    ∀ k A, Γ1 !! k = Some A → ∃ B, Γ0 !! k = Some B ∧ subtype Δ kd B A.

  Notation "Δ ⊢ Γ0 <:< Γ1" := (lty_sub Δ Plain Γ0 Γ1) (Γ0 at next level, at level 70, no associativity).

  Definition wf_lty (Γ: local_tys) := map_Forall (λ _, wf_ty) Γ.

  Lemma insert_wf_lty x ty Γ :
    wf_ty ty → wf_lty Γ → wf_lty (<[x := ty]>Γ).
  Proof.
    rewrite /wf_lty /= => h hl.
    rewrite map_Forall_lookup => k tk.
    rewrite lookup_insert_Some.
    case => [[? <-] | [? hk]]; first done.
    by apply hl in hk.
  Qed.

  Lemma lty_sub_constraint_trans Δ kd Γ0 Γ1:
    lty_sub Δ kd Γ0 Γ1 →
    ∀ Δ', Δentails kd Δ' Δ →
    lty_sub Δ' kd Γ0 Γ1.
  Proof.
    move => hΓ Δ' hΔ k A hA.
    apply hΓ in hA as (B & hB & h).
    exists B; split => //.
    by eapply subtype_constraint_trans.
  Qed.

  Definition bounded_lty n (Γ: local_tys) := map_Forall (λ _, bounded n) Γ.

  Lemma insert_bounded_lty n x ty Γ :
    bounded n ty → bounded_lty n Γ → bounded_lty n (<[x := ty]>Γ).
  Proof.
    rewrite /bounded_lty /= => h hl.
    rewrite map_Forall_lookup => k tk.
    rewrite lookup_insert_Some.
    case => [[? <-] | [? hk]]; first done.
    by apply hl in hk.
  Qed.

  Lemma bounded_lty_ge Γ n m:
    bounded_lty n Γ → m ≥ n → bounded_lty m Γ.
  Proof.
    move => /map_Forall_lookup h1 hge k ty h.
    apply h1 in h.
    by eapply bounded_ge.
  Qed.

  (* We allow method override: children can redeclare a method if types
   * are compatible:
   * - return type must be a subtype
   * - argument types must be a supertype
   *)
  Definition mdef_incl (Δ: list constraint) (sub super: methodDef) :=
    dom sub.(methodargs) = dom super.(methodargs) ∧
    (∀ k A B, sub.(methodargs) !! k = Some A →
    super.(methodargs) !! k = Some B → Δ ⊢ B <D: A) ∧
    Δ ⊢ sub.(methodrettype) <D: super.(methodrettype).

  Lemma mdef_incl_reflexive Δ: reflexive _ (mdef_incl Δ).
  Proof.
    move => mdef; split; first done.
    split; last done.
    by move => k A B -> [] ->.
  Qed.

  Lemma mdef_incl_subst Δ mdef0 mdef1 σ :
    map_Forall (λ _cname, wf_cdef_parent) pdefs →
    map_Forall (λ _, wf_cdef_constraints_bounded) pdefs →
    Forall wf_ty σ →
    mdef_incl Δ mdef0 mdef1 →
    mdef_incl (subst_constraints σ Δ) (subst_mdef σ mdef0) (subst_mdef σ mdef1).
  Proof.
    move => hp hb hσ.
    rewrite /mdef_incl /subst_mdef /=.
    case => [hdom [hargs hret]]; split; first by rewrite !dom_fmap_L.
    split; last by apply subtype_subst.
    move => k A B.
    rewrite !lookup_fmap_Some.
    case => tyA [<- hA].
    case => tyB [<- hB].
    apply subtype_subst => //.
    by eapply hargs.
  Qed.

  (* Any redeclared public method must correctly override its parent methods.
   * Also, if a parent method is public, it can't be overrided with a private
   * method.
   *
   *
   * Also, a class cannot redeclare a _private_ method if it is already
   *  present in any of its parents definition.
   *
   * This is a restriction we aim to lift later on. This first version
   * is here to enable desugaring a private field into a private getter/setter
   * pair of methods.
   *
   * TODO: remove this restriction and allow private methods to
   * be redefined in sub classes.
   *)
  Definition wf_method_override :=
    ∀ A B adef bdef m σ mA mB,
    pdefs !! A = Some adef →
    pdefs !! B = Some bdef →
    inherits_using A B σ →
    adef.(classmethods) !! m = Some mA →
    bdef.(classmethods) !! m = Some mB →
    match mB.(methodvisibility), mA.(methodvisibility) with
    | Public, Public => mdef_incl adef.(constraints) mA (subst_mdef σ mB)
    | Public, Private => False
    | Private, _ => False (* TODO : lift this *)
    end.

  (* Key lemma for soundness of method call:
   * if A <: B and they both have a method m (from resp. origA, origB) which
   * is public in B, then the origins must be ordered in the same way,
   * meaning origA <: origB.
   * This implies some relations on all the inheritance substitution.
   *)
  Lemma has_method_ordered A B σAB m origA mdefA origB mdefB:
    wf_method_override →
    map_Forall (λ _cname, wf_cdef_parent) pdefs →
    map_Forall (λ _, wf_cdef_constraints_bounded) pdefs →
    map_Forall (λ _cname, cdef_methods_bounded) pdefs →
    inherits_using A B σAB →
    has_method m A origA mdefA →
    has_method m B origB mdefB →
    (* mdefB.(methodvisibility) = Public → *)
    ∃ oA oB σA σB mA mB,
      pdefs !! origA = Some oA ∧
      pdefs !! origB = Some oB ∧
      oA.(classmethods) !! m = Some mA ∧
      oB.(classmethods) !! m = Some mB ∧
      inherits_using A origA σA ∧
      inherits_using B origB σB ∧
      mdefA = subst_mdef σA mA ∧
      mdefB = subst_mdef σB mB ∧
      (* mA.(methodvisibility) = Public ∧ *)
      mdef_incl (subst_constraints σA oA.(constraints)) mdefA (subst_mdef σAB mdefB) ∧
      (* A <: B <: orig A = orig B *)
      ((inherits_using B origA σB ∧
          origA = origB ∧
          mA = mB ∧
          subst_ty σAB <$> σB = σA) ∨
      (* A <: origA <: B <: origB *)
       (∃ σ, inherits_using origA B σ ∧
             subst_ty σA <$> σ = σAB ∧
             mdef_incl oA.(constraints) mA (subst_mdef σ (subst_mdef σB mB)))).
  Proof.
    move => ho hp hb hm hin hA hB (* hvB *).
    assert (hhA := hA).
    assert (hhB := hB).
    apply has_method_from_def in hA => //.
    apply has_method_from_def in hB => //.
    destruct hA as (oadef & oaorig & hoA & hmA & hmoA & [σA [hiA ->]]).
    destruct hB as (obdef & oborig & hoB & hmB & hmoB & [σB [hiB ->]]).
    exists oadef, obdef, σA, σB, oaorig, oborig.
    do 8 split => //.
    destruct (inherits_using_chain _ _ _ hp hin _ _ hiA) as [σ'' [ [<- h] | [<- h]]].
    - destruct (has_method_below_orig _ _ _ _ hp hm hhA _ _ _ hin h) as
        (? & ? & mbdef & ? & ? & hbm & ->); simplify_eq.
      destruct (has_method_fun _ _ _ _ _ _ hhB hbm) as [-> ->].
      simplify_eq.
      (* split; first done. *)
      assert (mdef_bounded (length σ'') oaorig).
      { assert (hoA' := hoA).
        apply hm in hoA.
        apply hoA in hmA.
        apply inherits_using_wf in h => //.
        destruct h as (? & ? & ? & h & _).
        apply wf_tyI in h as [? [? [hlen ?]]]; simplify_eq.
        by rewrite hlen.
      }
      split.
      { rewrite subst_mdef_mdef //.
        by apply mdef_incl_reflexive.
      }
      left.
      repeat split => //.
      assert (hh : inherits_using A origA (subst_ty σAB <$> σB))
        by by eapply inherits_using_trans.
      by rewrite (inherits_using_fun _ _ _ hp hiA _ hh).
    - assert (mdef_bounded (length σB) oborig).
      { assert (hoB' := hoB).
        apply hm in hoB.
        apply hoB in hmB.
        apply inherits_using_wf in hiB => //.
        destruct hiB as (? & ? & ? & hiB & _).
        apply wf_tyI in hiB as [? [? [hlen ?]]]; simplify_eq.
        by rewrite hlen.
      }
      assert (mdef_bounded (length σ'') (subst_mdef σB oborig)).
      { apply mdef_bounded_subst with (n := length σB) => //.
        apply inherits_using_wf in hiB => //.
        destruct hiB as (bdef & ? & ? & ? & _).
        apply inherits_using_wf in h => //.
        destruct h as (? & ? & ? & h & _).
        apply wf_tyI in h as [? [? [hlen ?]]]; simplify_eq.
        by rewrite hlen.
      }
      assert (hh: oaorig.(methodvisibility) = Public ∧
        mdef_incl (constraints oadef) oaorig (subst_mdef σ'' (subst_mdef σB oborig))).
      { rewrite subst_mdef_mdef //.
        assert (hino: inherits_using origA origB (subst_ty σ'' <$> σB))
          by by eapply inherits_using_trans.
        move: (ho _ _ _ _ _ _ _ _ hoA hoB hino hmA hmB).
        (* rewrite hvB. *)
        (* by destruct oaorig.(methodvisibility). *)
        (**)
        destruct oborig.(methodvisibility); last done.
        destruct oaorig.(methodvisibility); last done.
        done.
        (**)
      }
      destruct hh as [? ?].
      (* split; first done. *)
      split.
      { rewrite -subst_mdef_mdef //.
        apply mdef_incl_subst => //.
        apply inherits_using_wf in hiA => //.
        destruct hiA as (? & ? & ? & hiA & _).
        by apply wf_ty_classI in hiA.
      }
      right.
      exists σ''.
      by repeat split => //.
  Qed.
End SubtypeFacts.

(* Hints and notations are local to the section. Re-exporting them *)
Global Hint Constructors subtype : core.
Global Hint Constructors subtype_targs : core.


(*! Language | Semantics of Lowered Kôika programs !*)
Require Export Koika.Common Koika.Environments Koika.Syntax Koika.TypedSemantics Koika.LoweredSyntax.

Section Interp.
  Context {pos_t var_t rule_name_t reg_t ext_fn_t: Type}.
  Context {reg_t_eq_dec: EqDec reg_t}.

  Context {R: reg_t -> nat}.
  Context {Sigma: ext_fn_t -> CExternalSignature}.

  Context {REnv: Env reg_t}.

  Notation Log := (CLog R REnv).

  Notation rule := (rule pos_t var_t R Sigma).
  Notation action := (action pos_t var_t R Sigma).
  Notation scheduler := (scheduler pos_t rule_name_t).

  Definition lcontext (sig: lsig) :=
    context Bits.bits sig.

  Section Action.
    Context (r: REnv.(env_t) (fun idx => bits (R idx))).
    Context (sigma: forall f, CSig_denote (Sigma f)).

    Fixpoint interp_action
             {sig: lsig}
             {sz}
             (Gamma: lcontext sig)
             (sched_log: Log)
             (action_log: Log)
             (a: action sig sz)
    : option (Log * bits sz * (lcontext sig)) :=
      match a in LoweredSyntax.action _ _ _ _ ts sz return (lcontext ts -> option (Log * bits sz * (lcontext ts)))  with
      | Fail sz => fun _ =>
        None
      | Var k m => fun Gamma =>
        Some (action_log, cassoc m Gamma, Gamma)
      | Const cst => fun Gamma =>
        Some (action_log, cst, Gamma)
      | Seq r1 r2 => fun Gamma =>
        let/opt3 action_log, _, Gamma := interp_action Gamma sched_log action_log r1 in
        interp_action Gamma sched_log action_log r2
      | Assign k m ex => fun Gamma =>
        let/opt3 action_log, v, Gamma := interp_action Gamma sched_log action_log ex in
        Some (action_log, Ob, creplace m v Gamma)
      | @Bind _ _ _ _ _ _ sig _ sz sz' ex body => fun (Gamma : lcontext sig) =>
        let/opt3 action_log1, v, Gamma := interp_action Gamma sched_log action_log ex in
        let/opt3 action_log2, v, Gamma := interp_action (CtxCons sz v Gamma) sched_log action_log1 body in
        Some (action_log2, v, ctl Gamma)
      | If cond tbranch fbranch => fun Gamma =>
        let/opt3 action_log, cond, Gamma := interp_action Gamma sched_log action_log cond in
        if Bits.single cond then
          interp_action Gamma sched_log action_log tbranch
        else
          interp_action Gamma sched_log action_log fbranch
      | Read prt idx => fun Gamma =>
        if may_read sched_log prt idx then
          Some (log_cons idx (LE LogRead prt tt) action_log,
                match prt with
                | P0 => REnv.(getenv) r idx
                | P1 => match latest_write0 (log_app action_log sched_log) idx with
                       | Some v => v
                       | None => REnv.(getenv) r idx
                       end
                end,
                Gamma)
        else None
      | Write prt idx val => fun Gamma =>
        let/opt3 action_log, val, Gamma_new := interp_action Gamma sched_log action_log val in
        if may_write sched_log action_log prt idx then
          Some (log_cons idx (LE LogWrite prt val) action_log, Bits.nil, Gamma_new)
        else None
      | Unop fn arg1 => fun Gamma =>
        let/opt3 action_log, arg1, Gamma := interp_action Gamma sched_log action_log arg1 in
        Some (action_log, (CircuitPrimSpecs.sigma1 fn) arg1, Gamma)
      | Binop fn arg1 arg2 => fun Gamma =>
        let/opt3 action_log, arg1, Gamma := interp_action Gamma sched_log action_log arg1 in
        let/opt3 action_log, arg2, Gamma := interp_action Gamma sched_log action_log arg2 in
        Some (action_log, (CircuitPrimSpecs.sigma2 fn) arg1 arg2, Gamma)
      | ExternalCall fn arg1 => fun Gamma =>
        let/opt3 action_log, arg1, Gamma := interp_action Gamma sched_log action_log arg1 in
        Some (action_log, sigma fn arg1, Gamma)
      | APos _ a => fun Gamma =>
        interp_action Gamma sched_log action_log a
      end Gamma.

    Definition interp_rule (sched_log: Log) (rl: rule) : option Log :=
      match interp_action CtxEmpty sched_log log_empty rl with
      | Some (l, _, _) => Some l
      | None => None
      end.
  End Action.

  Section Scheduler.
    Context (r: REnv.(env_t) (fun idx => bits (R idx))).
    Context (sigma: forall f, CSig_denote (Sigma f)).
    Context (rules: rule_name_t -> rule).

    Fixpoint interp_scheduler'
             (sched_log: Log)
             (s: scheduler)
             {struct s} :=
      let interp_try rl s1 s2 :=
          match interp_rule r sigma sched_log (rules rl) with
          | Some l => interp_scheduler' (log_app l sched_log) s1
          | None => interp_scheduler' sched_log s2
          end in
      match s with
      | Done => sched_log
      | Cons r s => interp_try r s s
      | Try r s1 s2 => interp_try r s1 s2
      | SPos _ s => interp_scheduler' sched_log s
      end.

    Definition interp_scheduler (s: scheduler) :=
      interp_scheduler' log_empty s.
  End Scheduler.

  Definition interp_cycle (sigma: forall f, CSig_denote (Sigma f)) (rules: rule_name_t -> rule)
             (s: scheduler) (r: REnv.(env_t) (fun idx => bits (R idx))) :=
      commit_update r (interp_scheduler r sigma rules s).
End Interp.


Set Implicit Arguments.

Require Import Platform.Cito.ADT.
Require Import Platform.Cito.RepInv.

Module Make (Import E : ADT) (Import M : RepInv E).

  Require Import Platform.Cito.VerifCondOkNonCall.
  Module Import VerifCondOkNonCallMake := Make E M.
  Require Import Platform.Cito.VerifCondOkNonCall2.
  Module Import VerifCondOkNonCall2Make := Make E M.
  Require Import Platform.Cito.VerifCondOkCall.
  Module Import VerifCondOkCallMake := Make E M.
  Import CompileStmtSpecMake.
  Import InvMake.
  Import Semantics.
  Import SemanticsMake.
  Import InvMake2.

  Section TopSection.

    Require Import Platform.AutoSep.

    Variable vars : list string.

    Variable temp_size : nat.

    Variable imports : LabelMap.t assert.

    Variable imports_global : importsGlobal imports.

    Variable modName : string.

    Variable rv_postcond : W -> vals -> Prop.

    Notation do_compile := (CompileStmtImplMake.compile vars temp_size rv_postcond imports_global modName).

    Lemma verifCond_ok :
      forall s k (pre : assert),
        vcs (verifCond vars temp_size s k rv_postcond pre) ->
        vcs
          (VerifCond (do_compile s k pre)).
    Proof.

      unfold verifCond, imply; induction s.

      eapply verifCond_ok_skip; eauto.
      eapply verifCond_ok_seq; eauto.
      eapply verifCond_ok_if; eauto.
      eapply verifCond_ok_while; eauto.

      eapply verifCond_ok; eauto.

      eapply verifCond_ok_label; eauto.
      eapply verifCond_ok_assign; eauto.

    Qed.

  End TopSection.

End Make.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*          Jacques-Henri Jourdan, 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.     *)
(*                                                                     *)
(* *********************************************************************)

(** Architecture-dependent parameters for ARM *)

Require Import ZArith.
Require Import Fappli_IEEE.
Require Import Fappli_IEEE_bits.

Definition big_endian := false.

Notation align_int64 := 8%Z (only parsing).
Notation align_float64 := 8%Z (only parsing).

Program Definition default_pl : bool * nan_pl 53 := (false, nat_iter 51 xO xH).

Definition choose_binop_pl (s1: bool) (pl1: nan_pl 53) (s2: bool) (pl2: nan_pl 53) :=
  (** Choose second NaN if pl2 is sNaN but pl1 is qNan.
      In all other cases, choose first NaN *)
  (Pos.testbit (proj1_sig pl1) 51 &&
   negb (Pos.testbit (proj1_sig pl2) 51))%bool.

Global Opaque big_endian default_pl choose_binop_pl.


Require Import Coq.Strings.String.

From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype.
From deriving Require Import deriving.
From extructures Require Import ord fset fmap ffun fperm.

From CoqUtils Require Import nominal.

From memsafe Require Import basic structured.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section Separation.

Local Open Scope fset_scope.
Local Open Scope state_scope.

Local Notation locals := {fmap string -> value}.
Local Notation heap := {fmap ptr -> value}.
Local Notation state := (locals * heap)%type.

Implicit Type (e : expr) (c : com) (ls : locals) (h : heap)
              (s : state) (π : {fperm name}) (v : value)
              (P Q R : state -> Prop).

Definition triple P c Q :=
  forall s k, fsubset (vars_c c) (domm s.1) ->
              P s ->
              match eval_com c s k with
              | Done rs' => pbindr fset0 Q rs'
              | Error    => False
              | NotYet   => True
              end.

Definition separating_conjunction P Q s :=
  exists ls h1 h2,
    [/\ s = (ls, unionm h1 h2),
        P (ls, h1),
        Q (ls, h2) &
        fdisjoint (names (domm h1)) (names (domm h2)) ].

Local Infix "*" := separating_conjunction.

Definition ind_vars (xs : {fset string}) P :=
  forall s s', P s ->
               (forall x, x \notin xs -> s.1 x = s'.1 x) ->
               s.2 = s'.2 ->
               P s'.

Lemma sc_lift P Q A ls h1 h2 :
  pbindr fset0 P (hide A (Restr (ls, h1))) ->
  pbindr fset0 Q (hide A (Restr (ls, h2))) ->
  fdisjoint (names (domm h1)) (names (domm h2)) ->
  pbindr fset0 (P * Q) (hide A (Restr (ls, unionm h1 h2))).
Proof.
move=> Ph1 Qh2 dis A12 /= s /restr_eqP /= [π ids_π [eA es]] _.
move: ids_π.
rewrite fsetDUl /= namesm_union_disjoint ?fdisjoint_names_domm //.
rewrite (fsetDUl (names h1)) -[names ls :\: A]fsetUid -fsetUA.
rewrite [in X in _ :|: X]fsetUC 2!fsetUA -fsetUA (fsetUC (names h2 :\: A)).
rewrite -2!fsetDUl -(namespE (ls, h1)) -(namespE (ls, h2)) fdisjointUr.
case/andP=> [dis_π1 dis_π2].
exists (rename π ls), (rename π h1), (rename π h2).
rewrite -es pair_eqvar unionm_eqvar; split=> //.
- apply: (Ph1 (rename π A)); last exact: fdisjoint0s.
  rewrite -[LHS](@renameJ _ π) ?names_hider ?namesrE //.
  by rewrite hide_eqvar Restr_eqvar pair_eqvar.
- apply: (Qh2 (rename π A)); last exact: fdisjoint0s.
  rewrite -[LHS](@renameJ _ π) ?names_hider ?namesrE //.
  by rewrite hide_eqvar Restr_eqvar pair_eqvar.
by rewrite -![domm (rename _ _)]domm_eqvar -fdisjoint_eqvar renameT.
Qed.

Lemma frame_rule P Q R c :
  triple P c Q ->
  ind_vars (mod_vars_c c) R ->
  triple (P * R) c (Q * R).
Proof.
move=> t ind s k sub [ls [h1 [h2 [e ph1 ph2 dis]]]].
rewrite {}e {s} in sub *.
move/(_ (ls, h1) k sub ph1): t.
rewrite -{2}[ls]unionm0.
case ev: (eval_com c (ls, h1) k)=> [rs'| |] //=; first last.
  by rewrite (@frame_loop _ (ls, h1) (emptym, h2)).
move=> Q_rs'; rewrite (@frame_ok _ (ls, h1) (emptym, h2) _ _ sub dis ev).
case: rs' / (restrP (names (ls, h1) :|: names ((emptym, h2) : state)) rs')
          Q_rs' ev => /= A [ls' h1'] dis'' sub' Q_rs' ev.
move: dis''; rewrite fdisjointUl=> /andP [dis1 dis2].
rewrite maprE // /stateu unionm0.
rewrite namespE /= namesm_empty fset0U in dis2.
apply: sc_lift=> //.
  move=> /= A' s2' /restr_eqP [π].
  rewrite namespE fsetDUl /= (fsetDidPl dis2) fdisjointUr.
  case/andP=> dis_ls' dis_h2.
  rewrite pair_eqvar /= (renameJ dis_h2) => - [eA <-] _.
  apply/ind; eauto=> /= x nin_x.
  move: (mod_vars_cP ev nin_x); rewrite maprE ?fdisjoint0s //=.
  move/(congr1 (@oexpose _)); rewrite oexposeE oexposeE0.
  case: ifP=> // dis''' [<-].
  rewrite renamemE renameT renameJ // fdisjointC.
  rewrite fdisjointC in dis_ls'.
  apply/fdisjoint_trans; eauto.
  apply/fsubsetP=> /= i in_i; apply/fsetDP; split.
    case e: getm in_i=> [v|]; try by rewrite in_fset0.
    move=> in_i; apply/namesmP/@PMFreeNamesVal; eauto.
  by move: i in_i; apply/fdisjointP; rewrite fdisjointC.
have := @eval_com_blocks _ (ls, h1) c k dis.
rewrite ev pbind_resE /=.
have: fdisjoint (names (domm h2)) A.
  by apply: fdisjoint_trans dis2; eapply nom_finsuppP; finsupp.
move: (names (domm h2)) => A' disA'.
by rewrite pbindrE //= namesfsnE.
Qed.

Definition weak_triple P c Q :=
  forall s k,
    fsubset (vars_c c) (domm s.1) ->
    P s ->
    if eval_com c s k is Done rs' then
      pbindr fset0 Q rs'
    else True.

Definition strong_separating_conjunction P Q s :=
  exists ls h1 h2,
    [/\ s = (ls, unionm h1 h2),
        P (ls, h1),
        Q (ls, h2) &
        fdisjoint (names (ls, h1)) (names (domm h2)) ].

Local Infix "*>" := strong_separating_conjunction (at level 20).

Lemma ssc_lift P Q A ls h1 h2 :
  pbindr fset0 P (hide A (Restr (ls, h1))) ->
  pbindr fset0 Q (hide A (Restr (ls, h2))) ->
  fdisjoint (names (ls, h1)) (names (domm h2)) ->
  pbindr fset0 (P *> Q) (hide A (Restr (ls, unionm h1 h2))).
Proof.
move=> Ph1 Qh2 dis A12 /= s /restr_eqP /= [π ids_π [eA es]] _.
move: ids_π.
rewrite fsetDUl /= namesm_union_disjoint ?fdisjoint_names_domm //; last first.
  suffices h : fsubset (names (domm h1)) (names (ls, h1)).
    by apply: fdisjoint_trans; eauto.
  by rewrite fsubsetU //= [_ _ (names h1)]fsubsetU ?orbT ?fsubsetxx.
rewrite (fsetDUl (names h1)) -[names ls :\: A]fsetUid -fsetUA.
rewrite [in X in _ :|: X]fsetUC 2!fsetUA -fsetUA (fsetUC (names h2 :\: A)).
rewrite -2!fsetDUl -(namespE (ls, h1)) -(namespE (ls, h2)) fdisjointUr.
case/andP=> [dis_π1 dis_π2].
exists (rename π ls), (rename π h1), (rename π h2).
rewrite -es pair_eqvar unionm_eqvar; split=> //.
- apply: (Ph1 (rename π A)); last exact: fdisjoint0s.
  rewrite -[LHS](@renameJ _ π) ?names_hider ?namesrE //.
  by rewrite hide_eqvar Restr_eqvar pair_eqvar.
- apply: (Qh2 (rename π A)); last exact: fdisjoint0s.
  rewrite -[LHS](@renameJ _ π) ?names_hider ?namesrE //.
  by rewrite hide_eqvar Restr_eqvar pair_eqvar.
by rewrite -![domm (rename _ _)]domm_eqvar -fdisjoint_eqvar renameT.
Qed.

Lemma weak_frame_rule P Q R c :
  weak_triple P c Q ->
  ind_vars (mod_vars_c c) R ->
  weak_triple (P *> R) c (Q *> R).
Proof.
move=> t ind s k sub [ls [h1 [h2 [e ph1 ph2 dis]]]].
rewrite {}e {s} in sub *.
move/(_ (ls, h1) k sub ph1): t.
rewrite -{2}[ls]unionm0.
have dis': fdisjoint (names (domm h1)) (names (domm h2)).
  move: dis; rewrite fdisjointUl=> /andP [_] /=.
  by rewrite fdisjointUl=> /andP [].
case ev: (eval_com c (ls, h1) k)=> [rs'| |] //=; first last.
- by rewrite (@frame_loop _ (ls, h1) (emptym, h2)).
- by rewrite (@frame_error _ (ls, h1) (emptym, h2)).
move=> Q_rs'; rewrite (@frame_ok _ (ls, h1) (emptym, h2) _ _ sub dis' ev).
case: rs' / (restrP (names (ls, h1) :|: names ((emptym, h2) : state)) rs')
          Q_rs' ev => /= A [ls' h1'] dis'' sub' Q_rs' ev.
move: dis''; rewrite fdisjointUl=> /andP [dis1 dis2].
rewrite maprE // /stateu unionm0.
rewrite namespE /= namesm_empty fset0U in dis2.
apply: ssc_lift=> //.
  move=> /= A' s2' /restr_eqP [π].
  rewrite namespE fsetDUl /= (fsetDidPl dis2) fdisjointUr.
  case/andP=> dis_ls' dis_h2.
  rewrite pair_eqvar /= (renameJ dis_h2) => - [eA <-] _.
  apply/ind; eauto=> /= x nin_x.
  move: (mod_vars_cP ev nin_x); rewrite maprE ?fdisjoint0s //=.
  move/(congr1 (@oexpose _)); rewrite oexposeE oexposeE0.
  case: ifP=> // dis''' [<-].
  rewrite renamemE renameT renameJ // fdisjointC.
  rewrite fdisjointC in dis_ls'.
  apply/fdisjoint_trans; eauto.
  apply/fsubsetP=> /= i in_i; apply/fsetDP; split.
    case e: getm in_i=> [v|]; try by rewrite in_fset0.
    move=> in_i; apply/namesmP/@PMFreeNamesVal; eauto.
  by move: i in_i; apply/fdisjointP; rewrite fdisjointC.
have: fsubset (names (eval_com c (ls, h1) k)) (names (ls, h1)).
  eapply nom_finsuppP; finsupp.
rewrite ev namesresE names_hider namesrE fsubDset fsetUC => ?.
apply: fdisjoint_trans; first eauto.
rewrite fdisjointUl dis fdisjointC.
apply: fdisjoint_trans; eauto.
by eapply nom_finsuppP; finsupp.
Qed.

End Separation.


(* begin hide *)
From ITree Require Import
     Eq.Eqit
     ITree
     FailFacts
     Events.Exception.

From Vellvm Require Import
     Utils.PostConditions
     Utils.PropT
     Utils.TFor
     Utils.Tactics.

From Paco Require Import paco.

From ExtLib Require Import
     Structures.Monad.

From Coq Require Import
     Morphisms Lia.

Import ITreeNotations.
Local Open Scope itree.
(* end hide *)

(** * Reasoning about successful computations

  Compilers are typically only required to preserve the behavior of valid programs.
  Correctness statements are therefore phrased in terms "for any program c, if c
  has a well defined semantics, then ...".
  Having a well defined semantics when manipulating an operational semantics is
  typically expressed as never reaching a blocking state, or an error state.
  In this file, we develop the necessary machinery to express and reason about
  this same fact in an itree-based semantics.

  We choose here to assume that failure is represented using the [exceptT] domain of
  events, and to interpret this failure into a trivial option monad.
  The property of "well definedness" of a computation is then expressed after interpretation
  using the [has_post] unary logic developed in [./Utils/PostConditions.v]: it simply asserts
  that the computation does not fail (see [no_failure]).

  Interestingly, this requires to process [eutt]-based equations forward as opposed to
  backward: we know for an hypothesis an evidence of the form [has_post (x <- c;; k) P]
  and need to deduce information about [c] and [k]. It so happens that one needs to be
  a little bit more careful when processing monadic equivalences forward than backward:
  we use to this end notably [eutt_clo_bind_returns].

  This approach is heavily used in the Helix development.

*)

(* For some reason the new definition of [ecofix] in itrees loops here.
  We redefine the old one for now.
*)
Require Import Paco.pacotac_internal.

 Tactic Notation "ecofix" ident(CIH) "with" ident(gL) ident(gH) :=
   repeat red;
   paco_pre2;
   eapply euttG_cofix;
   paco_post2 CIH with gL;
   paco_post2 CIH with gH.

 Tactic Notation "ecofix" ident(CIH) := ecofix CIH with gL gH.

Section ITreeUtilities.

(* TODO: move to itree *)
Lemma interp_state_iter :
  forall {A R S : Type} (E F : Type -> Type) (s0 : S) (a0 : A) (h : E ~> Monads.stateT S (itree F)) f,
    State.interp_state (E := E) (T := R) h (ITree.iter f a0) s0 ≈
                 @Basics.iter _ MonadIter_stateT0 _ _ (fun a s => State.interp_state h (f a) s) a0 s0.
Proof.
  unfold iter, CategoryKleisli.Iter_Kleisli, Basics.iter, MonadIter_stateT0, Basics.iter, MonadIter_itree in *; cbn.
  einit. ecofix CIH; intros.
  rewrite 2 unfold_iter; cbn.
  rewrite !Eqit.bind_bind.
  setoid_rewrite bind_ret_l.
  rewrite StateFacts.interp_state_bind.
  ebind; econstructor; eauto.
  - reflexivity.
  - intros [s' []] _ []; cbn.
    + rewrite StateFacts.interp_state_tau.
      estep.
    + rewrite StateFacts.interp_state_ret; apply reflexivity.
Qed.

Lemma interp_fail_iter :
  forall {A R : Type} (E F : Type -> Type) (a0 : A) (h : E ~> failT (itree F)) f,
    interp_fail (E := E) (T := R) h (ITree.iter f a0) ≈
                @Basics.iter _ failT_iter _ _ (fun a => interp_fail h (f a)) a0.
Proof.
  unfold Basics.iter, failT_iter, Basics.iter, MonadIter_itree in *; cbn.
  einit. ecofix CIH; intros *.
  rewrite 2 unfold_iter; cbn.
  rewrite !Eqit.bind_bind.
  rewrite interp_fail_bind.
  ebind; econstructor; eauto.
  reflexivity.
  intros [[a1|r1]|] [[a2|r2]|] EQ; inv EQ.
  - rewrite bind_ret_l.
    rewrite interp_fail_tau.
    estep.
  - rewrite bind_ret_l, interp_fail_ret.
    eret.
  - rewrite bind_ret_l.
    eret.
Qed.

Lemma translate_iter :
  forall {A R : Type} (E F : Type -> Type) (a0 : A) (h : E ~> F) f,
    translate (E := E) (F := F) (T := R) h (ITree.iter f a0) ≈
              ITree.iter (fun a => translate h (f a)) a0.
Proof.
  intros; revert a0.
  einit; ecofix CIH; intros.
  rewrite 2 unfold_iter; cbn.
  rewrite TranslateFacts.translate_bind.
  ebind; econstructor; eauto.
  - reflexivity.
  - intros [|] [] EQ; inv EQ.
    + rewrite TranslateFacts.translate_tau; estep.
    + rewrite TranslateFacts.translate_ret; apply reflexivity.
Qed.

End ITreeUtilities.

(* We don't care in this context about having an informative failure,
  we just dive into the option monad.
   *)
Section Handle_Fail.

  Definition h_fail {T E} : exceptE T ~> failT (itree E) :=
    fun _ _ => Ret None.

  Definition trigger_fail {E} : E ~> failT (itree E)
    := fun _ e => Vis e (fun x => Ret (Some x)).

  (* TODO: Use [over], or possibly [exceptE -< E] *)
  Definition run_fail {E T}
    : itree (exceptE T +' E) ~> failT (itree E)
    := interp_fail (case_ h_fail trigger_fail).

End Handle_Fail.

Lemma post_returns : forall {E X} (t : itree E X), t ⤳ fun a => Returns a t.
Proof.
  intros; eapply eqit_mon; eauto.
  2: eapply PropT.eutt_Returns.
  intros ? ? [<- ?]; auto.
Qed.

Lemma eutt_clo_bind_returns {E R1 R2 RR U1 U2 UU}
      (t1 : itree E U1) (t2 : itree E U2)
      (k1 : U1 -> itree E R1) (k2 : U2 -> itree E R2)
      (EQT: @eutt E U1 U2 UU t1 t2)
      (EQK: forall u1 u2, UU u1 u2 -> Returns u1 t1 -> Returns u2 t2 -> eutt RR (k1 u1) (k2 u2)):
  eutt RR (x <- t1;; k1 x) (x <- t2;; k2 x).
Proof.
  intros; eapply eutt_post_bind_gen; eauto using post_returns.
Qed.

Section No_Failure.

  (* We are often interested in assuming that a computation does not fail.
     This file develop ways to assert and reason about such a fact assuming that
     the tree has been interpreted into the [failT (itree E)] monad.
     Note: nothing in this file is specific to Vellvm, it should eventually be
     moved to the itree library.
   *)

  Definition no_failure {E X} (t : itree E (option X)) : Prop :=
    t ⤳ fun x => ~ x = None.

  Global Instance no_failure_eutt {E X} : Proper (eutt eq ==> iff) (@no_failure E X).
  Proof.
    intros t s EQ; unfold no_failure; split; intros ?; [rewrite <- EQ | rewrite EQ]; auto.
  Qed.

  (* This is a non-trivial proof, not a direct consequence of an inversion lemma.
     This states essentially that if `no_failure` holds at the end of the execution,
     then it is an invariant of the execution.
   *)
  Lemma no_failure_bind_prefix : forall {E X Y} (t : itree E (option X)) (k : X -> itree E (option Y)),
      no_failure (bind (m := failT (itree E)) t k) ->
      no_failure t.
  Proof.
    unfold no_failure,has_post; intros E X Y.
    einit; ecofix CIH.
    intros * NOFAIL.
    cbn in NOFAIL. rewrite unfold_bind in NOFAIL.
    rewrite itree_eta.
    destruct (observe t) eqn:EQt.
    - eret.
      cbn in *.
      destruct r; [intros abs; inv abs | exfalso].
      apply eutt_Ret in NOFAIL; apply NOFAIL; auto.
    - estep.
      cbn in *.
      ebase; right; eapply CIH.
      rewrite <- tau_eutt; eauto.
    - estep.
      cbn in *.
      intros ?; ebase.
      right; eapply CIH0.
      eapply eqit_inv_Vis in NOFAIL; eauto.
  Qed.

  Lemma no_failure_bind_cont : forall {E X Y} (t : _ X) (k : X -> _ Y),
      no_failure (bind (m := failT (itree E)) t k) ->
      forall u, Returns (E := E) (Some u) t ->
              no_failure (k u).
  Proof.
    intros * NOFAIL * ISRET.
    unfold no_failure in *.
    cbn in *.
    eapply PropT.eqit_bind_Returns_inv in NOFAIL; eauto.
    apply NOFAIL.
  Qed.

  Lemma no_failure_Ret :
    forall E T X x, @no_failure E X (@run_fail E T X (Ret x)).
  Proof.
    intros.
    unfold run_fail, no_failure.
    cbn.
    rewrite interp_fail_Ret.
    apply eutt_Ret; intros abs; inv abs.
  Qed.

  Lemma failure_throw : forall E Err X (s: Err),
      ~ no_failure (E := E) (X := X) (@run_fail E Err X (throw (E := _ +' E) s)).
  Proof.
    intros * abs.
    unfold no_failure, throw, run_fail in *.
    rewrite interp_fail_vis in abs.
    cbn in *.
    unfold h_fail in *; rewrite  !bind_ret_l in abs.
    eapply eutt_Ret in abs.
    apply abs; auto.
  Qed.

  (* The following lemmas reason about [tfor] in the specific case where the body goes
   into the failure monad.
   They are quite a bit ugly as intrinsically [tfor] unfolds using the itree [bind] while
   [no_failure] relies on the failT [bind]. Improving the situation will require to
   develop better general monadic reasoning principles rather than re-internalize things
   into the [itree E] monad forcibly.
   *)
  Lemma tfor_fail_None : forall {E A} i j (body : nat -> A -> itree E (option A)),
      (i <= j)%nat ->
      tfor (fun k x => match x with
                    | Some a0 => body k a0
                    | None => Ret None
                    end) i j None ≈ Ret None.
  Proof.
    intros E A i j body; remember (j - i)%nat as k; revert i Heqk; induction k as [| k IH].
    - intros i EQ INEQ; replace j with i by lia; rewrite tfor_0; reflexivity.
    - intros i EQ INEQ.
      rewrite tfor_unroll; [|lia].
      rewrite bind_ret_l, IH; [reflexivity | lia | lia].
  Qed.

  (* One step unrolling of the combinator *)
  Lemma tfor_unroll_fail: forall {E A} i j (body : nat -> A -> itree E (option A)) a0,
      (i < j)%nat ->
      tfor (fun k x => match x with
                    | Some a0 => body k a0
                    | None => Ret None
                    end) i j a0 ≈
           bind (m := failT (itree E))
           (match a0 with
            | Some a0 => body i a0
            | None => Ret None
            end) (fun a =>
                    tfor (fun k x =>
                            match x with
                            | Some a0 => body k a0
                            | None => Ret None
                            end) (S i) j (Some a)).
  Proof.
    intros *.
    remember (j - i)%nat as k.
    revert i Heqk a0.
    induction k as [| k IH].
    - lia.
    - intros i EQ a0 INEQ.
      rewrite tfor_unroll; auto.
      cbn.
      destruct a0 as [a0 |]; cycle 1.
      + rewrite !bind_ret_l.
        rewrite tfor_fail_None; [reflexivity | lia].
      + apply eutt_eq_bind.
        intros [a1|]; cycle 1.
        * rewrite tfor_fail_None; [reflexivity | lia].
        * destruct (PeanoNat.Nat.eq_dec (S i) j).
          {
            subst.
            rewrite tfor_0; reflexivity.
          }
          destruct k; [lia |].
          rewrite (IH (S i)); [| lia | lia].
          reflexivity.
  Qed.

  Lemma no_failure_tfor : forall {E A} (body : nat -> A -> itree E (option A)) n m a0,
      no_failure (tfor (fun k x => match x with
                                | Some a => body k a
                                | None => Ret None
                                end) n m a0) ->
      forall k a,
        (n <= k < m)%nat ->
        Returns (Some a) (tfor (fun k x => match x with
                                        | Some a => body k a
                                        | None => Ret None
                                        end) n k a0) ->
        no_failure (body k a).
  Proof.
    intros E A body n m.
    remember (m - n)%nat as j.
    revert n Heqj.
    induction j as [| j IH].
    - intros n EQ a0 NOFAIL k a [INEQ1 INEQ2] RET.
      assert (n = m) by lia; subst.
      lia.
    - intros n EQ a0 NOFAIL k a [INEQ1 INEQ2] RET.
      destruct (PeanoNat.Nat.eq_dec k n).
      + subst.
        clear INEQ1.
        rewrite tfor_unroll_fail in NOFAIL; [| auto].
        rewrite tfor_0 in RET.
        apply Returns_Ret in RET.
        subst.
        apply no_failure_bind_prefix in NOFAIL; auto.
      + specialize (IH (S n)).
        forward IH; [lia |].
        rewrite tfor_unroll_fail in NOFAIL; [| lia].
        rewrite tfor_unroll_fail in RET; [| lia].
        cbn in RET.
        apply Returns_bind_inversion in RET.
        destruct RET as (a1 & RET1 & RET2).
        destruct a0 as [a0|]; cycle 1.
        { cbn in *.
          rewrite bind_ret_l in NOFAIL.
          apply eutt_Ret in NOFAIL; contradiction NOFAIL; auto.
        }
        cbn in *.
        destruct a1 as [a1|]; cycle 1.
        {
          apply Returns_Ret in RET2.
          inv RET2.
        }
        apply no_failure_bind_cont with (u := a1) in NOFAIL; auto.
        eapply IH; eauto.
        lia.
  Qed.

End No_Failure.