(* * Step Machine of the Heap Machine Simulator *)

From Undecidability Require Import TM.Code.ProgrammingTools LM_heap_def.
From Undecidability.TM.L Require Import Alphabets CaseCom LookupTM JumpTargetTM.
From Undecidability Require Import TM.Code.ListTM TM.Code.CaseList TM.Code.CasePair TM.Code.CaseSum.

Local Arguments plus : simpl never.
Local Arguments mult : simpl never.

Local Hint Resolve isVoid_isVoid_size : core.

(* Here we compose the [Lookup] and [JumpTarget] machines. *)

Section StepMachine.

  Implicit Types H : Heap.
  Implicit Types T V : list HClos.
  Implicit Types a b c : HAdd.
  Implicit Types g : HClos.
  Implicit Types (P Q : Pro).

  (* The machine operates on lists of closures and on a heap, so we need a closure-list alphabet and a heap alphabet. *)
  Variable sigStep : finType.
  Variable retr_closures_step : Retract (sigList sigHClos) sigStep.
  Variable retr_heap_step : Retract sigHeap sigStep.

  Set Default Proof Using "Type".

  (* Retracts *)
  (* Closures *)
  Local Definition retr_clos_step : Retract sigHClos sigStep := ComposeRetract retr_closures_step _.

  (* Closure addresses *)

  Definition retr_pro_clos : Retract sigPro sigHClos := _.
  Local Definition retr_pro_step : Retract sigPro sigStep := ComposeRetract retr_clos_step retr_pro_clos.
  Local Definition retr_tok_step : Retract sigCom sigStep := ComposeRetract retr_pro_step _.

  Local Definition retr_nat_clos_ad : Retract sigNat sigHClos := Retract_sigPair_X _ (Retract_id _).
  Local Definition retr_nat_step_clos_ad : Retract sigNat sigStep := ComposeRetract retr_clos_step retr_nat_clos_ad.

  Local Definition retr_nat_clos_var : Retract sigNat sigHClos := Retract_sigPair_Y _ _.
  Local Definition retr_nat_step_clos_var : Retract sigNat sigStep := ComposeRetract retr_clos_step retr_nat_clos_var.

  (* Instance of the [Lookup] and [JumpTarget] machine *)
  Local Definition Step_Lookup := Lookup retr_clos_step retr_heap_step.

  (* Cons a closure to a closure list, if the programm of the closure is not empty, and reset the program but not the address of the closure *)

  Definition TailRec_size (T : list HClos) (P : Pro) (a : HAdd) : Vector.t (nat->nat) 3 :=
    match P with
    | nil => [| id; Reset_size P; id|]
    | c :: P' => [| (*0*) Constr_cons_size (a,P); (*1*) Constr_pair_size a >> Reset_size (a,P); (*2*) id |]
    end.

  Definition TailRec_Rel : pRel sigStep^+ unit 3 :=
    ignoreParam (
        fun tin tout =>
          forall T P a (s0 s1 s2 : nat),
            tin[@Fin0] ≃(;s0) T ->
            tin[@Fin1] ≃(retr_pro_step;s1) P ->
            tin[@Fin2] ≃(retr_nat_step_clos_ad;s2) a ->
            tout[@Fin0] ≃(;TailRec_size T P a @>Fin0 s0) tailRecursion (a, P) T /\
            isVoid_size tout[@Fin1] (TailRec_size T P a @>Fin1 s1) /\
            tout[@Fin2] ≃(retr_nat_step_clos_ad; TailRec_size T P a @>Fin2 s2) a
      ).

  Definition TailRec : pTM sigStep^+ unit 3 :=
    If (IsNil sigCom_fin ⇑ retr_pro_step @ [|Fin1|])
       (Reset _ @ [|Fin1|])
       (Constr_pair sigHAdd_fin sigPro_fin ⇑ retr_clos_step @ [|Fin2; Fin1|];;
        Constr_cons sigHClos_fin ⇑ _ @ [|Fin0; Fin1|];;
        Reset _ @ [|Fin1|]).

  Lemma TailRec_Realise : TailRec ⊨ TailRec_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold TailRec. TM_Correct. }
    {
      intros tin ((), tout) H. intros T P a s0 s1 s2 HEncT HEncP HEncA.
      unfold TailRec_size.
      destruct H; TMSimp.
      - modpon H. destruct P as [ | c P']; auto; modpon H. modpon H0. repeat split; auto.
      - modpon H. destruct P as [ | c P']; auto; modpon H.
        specialize (H0 a (c :: P')). modpon H0.
        specialize (H2 T (a, c :: P')). modpon H2.
        specialize H4 with (x := (a, c :: P')). modpon H4.
        repeat split; auto.
    }
  Qed.

  Local Arguments TailRec_size : simpl never.
  Local Arguments tailRecursion : simpl never.

  Definition TailRec_steps P a :=
    match P with
    | nil => 1 + IsNil_steps + Reset_steps nil
    | t::P => 1 + IsNil_steps + 1 + Constr_pair_steps a + 1 + Constr_cons_steps (a,t::P) + Reset_steps (a, t :: P)
    end.

  Definition TailRec_T : tRel sigStep^+ 3 :=
    fun tin k =>
      exists T P a, tin[@Fin0] ≃ T /\
               tin[@Fin1] ≃(retr_pro_step) P /\
               tin[@Fin2] ≃(retr_nat_step_clos_ad) a /\
               TailRec_steps P a <= k.

  Lemma TailRec_Terminates : projT1 TailRec ↓ TailRec_T.
  Proof.
    eapply TerminatesIn_monotone.
    { unfold TailRec. TM_Correct.
    }
    {
      intros tin k (T&P&a&HEncT&HEncP&HEncA&Hk). unfold TailRec_steps in Hk.
      destruct P as [ | t P]; cbn.
      - exists (IsNil_steps), (Reset_steps nil). repeat split; try lia.
        intros tmid b (HIsNil&IsNilInj); TMSimp. modpon HIsNil. destruct b; auto; modpon HIsNil. eauto.
      - exists (IsNil_steps), (1 + Constr_pair_steps a + 1 + Constr_cons_steps (a,t::P) + Reset_steps (a, (t::P))).
        repeat split; try lia.
        intros tmid b (HIsNil&IsNilInj); TMSimp. modpon HIsNil. destruct b; auto; modpon HIsNil.
        exists (Constr_pair_steps a), (1 + Constr_cons_steps (a,t::P) + Reset_steps (a,t::P)). repeat split; try lia.
        { hnf; cbn. eexists; split. simpl_surject; contains_ext. reflexivity. }
        intros tmid0_ () (HPair&HPairInj); TMSimp.
        specialize (HPair a (t::P)); modpon HPair.
        exists (Constr_cons_steps (a,t::P)), (Reset_steps (a,t::P)). repeat split; try lia.
        { hnf; cbn. do 2 eexists; repeat split; simpl_surject; eauto. }
        intros tmid1_ () (HCons&HConsInj); TMSimp. specialize (HCons T (a,t::P)). modpon HCons.
        exists (a, t :: P). split; eauto.
    }
  Qed.

  (* Like [TailRec], but doesn't check whether the program is empty, and resets [a] and [Q] *)

  Definition ConsClos_size (T : list HClos) (Q : Pro) (a : HAdd) : Vector.t (nat->nat) 3 :=
    [| Constr_cons_size (a,Q); Reset_size a; Constr_pair_size a >> Reset_size (a, Q) |].

  Definition ConsClos_Rel : pRel sigStep^+ unit 3 :=
    ignoreParam (
        fun tin tout =>
          forall T Q a (s0 s1 s2 : nat),
            tin[@Fin0] ≃(;s0) T ->
            tin[@Fin1] ≃(retr_nat_step_clos_ad;s1) a ->
            tin[@Fin2] ≃(retr_pro_step;s2) Q ->
            tout[@Fin0] ≃(;ConsClos_size T Q a @>Fin0 s0) (a, Q) :: T /\
            isVoid_size tout[@Fin1] (ConsClos_size T Q a @>Fin1 s1) /\
            isVoid_size tout[@Fin2] (ConsClos_size T Q a @>Fin2 s2)
      ).

  Definition ConsClos : pTM sigStep^+ unit 3 :=
    Constr_pair sigHAdd_fin sigPro_fin ⇑ retr_clos_step @ [|Fin1; Fin2|];;
    Constr_cons sigHClos_fin ⇑ _ @ [|Fin0; Fin2|];;
    Reset _ @ [|Fin2|];;
    Reset _ @ [|Fin1|].

  Lemma ConsClos_Realise : ConsClos ⊨ ConsClos_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold ConsClos. TM_Correct.
    }
    {
      intros tin ((), tout) H. intros T Q a s0 s1 s2 HEncT HEncA HEncQ.
      TMSimp.
      specialize (H a Q). modpon H. (* Constr_pair *)
      specialize (H0 T (a, Q)). modpon H0. (* Constr_cons *)
      specialize H2 with (x := (a, Q)). modpon H2. (* Reset HClos *)
      modpon H4. (* Reset HAdd *)
      repeat split; auto.
    }
  Qed.

  Local Arguments ConsClos_size : simpl never.

  Definition ConsClos_steps Q a :=
    3 + Constr_pair_steps a + Constr_cons_steps (a,Q) + Reset_steps (a,Q) + Reset_steps a.

  Definition ConsClos_T : tRel sigStep^+ 3 :=
    fun tin k =>
          exists T Q a,
            tin[@Fin0] ≃ T /\
            tin[@Fin1] ≃(retr_nat_step_clos_ad) a /\
            tin[@Fin2] ≃(retr_pro_step) Q /\
            ConsClos_steps Q a <= k.

  Lemma ConsClos_Terminates : projT1 ConsClos ↓ ConsClos_T.
  Proof.
    eapply TerminatesIn_monotone.
    { unfold ConsClos. TM_Correct.
    }
    {
      intros tin k. intros (T&Q&a&HEncT&HEnca&HEncQ&Hk). unfold ConsClos_steps in Hk.
      exists (Constr_pair_steps a), (1 + Constr_cons_steps (a,Q) + 1 + Reset_steps (a,Q) + Reset_steps a).
      cbn; repeat split; try lia.
      { hnf; cbn. exists a. repeat split; simpl_surject; eauto. }
      intros tmid () (HPair&HPairInj); TMSimp. modpon HPair.
      exists (Constr_cons_steps (a,Q)), (1 + Reset_steps (a,Q) + Reset_steps a).
      cbn; repeat split; try lia.
      { hnf; cbn. exists T, (a, Q). repeat split; simpl_surject; eauto. }
      intros tmid0_ () (HCons&HConsInj); TMSimp. specialize (HCons T (a,Q)); modpon HCons.
      exists (Reset_steps (a,Q)), (Reset_steps a).
      cbn; repeat split; try lia; eauto.
      intros tmid1_ () (HReset&HResetInj); TMSimp. modpon HReset.
      exists a. split; eauto.
    }
  Qed.

  Definition Step_lam_size (T V : list HClos) (H : Heap) (a : HAdd) (P : Pro) : Vector.t (nat->nat) 10 :=
    match jumpTarget 0 [] P with
    | Some (Q, P') =>
      (JumpTarget_size P @>> [|Fin3; Fin6; Fin7; Fin8; Fin9|]) >>> (TailRec_size T P' a @>> [|Fin0; Fin3; Fin4|]) >>> (ConsClos_size V Q a @>> [|Fin1; Fin4; Fin6|])
    | _ => default
    end.

  Definition Step_lam_Rel : pRel sigStep^+ bool 10 :=
    fun tin '(yout, tout) =>
      forall (T V : list HClos) (H : Heap) (a : HAdd) (P : Pro) (s0 s1 s2 s3 s4 : nat) (sr : Vector.t nat 5),
        let size := Step_lam_size T V H a P in
        tin[@Fin0] ≃(;s0) T ->
        tin[@Fin1] ≃(;s1) V ->
        tin[@Fin2] ≃(;s2) H ->
        tin[@Fin3] ≃(retr_pro_step;s3) P ->
        tin[@Fin4] ≃(retr_nat_step_clos_ad;s4) a ->
        (forall i : Fin.t 5, isVoid_size tin[@FinR 5 i] sr[@i]) ->
        match yout with
        | true =>
          exists (P' Q : Pro),
          jumpTarget 0 [] P = Some (Q, P') /\
          tout[@Fin0] ≃(;size@>Fin0 s0) tailRecursion (a, P') T /\
          tout[@Fin1] ≃(;size@>Fin1 s1) (a, Q) :: V /\
          tout[@Fin2] ≃(;size@>Fin2 s2) H /\
          (forall i : Fin.t 7, isVoid_size tout[@FinR 3 i] (size@>(FinR 3 i) (s3:::s4:::sr)[@i]))
        | false => jumpTarget 0 [] P = None
        end.

  Definition Step_lam : pTM sigStep^+ bool 10 :=
    If (JumpTarget ⇑ retr_pro_step @ [|Fin3; Fin6; Fin7; Fin8; Fin9|])
       (Return (TailRec @ [|Fin0; Fin3; Fin4|];;
                ConsClos @ [|Fin1; Fin4; Fin6|])
               true)
       (Return Nop false).

  Lemma Step_lam_Realise : Step_lam ⊨ Step_lam_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold Step_lam. TM_Correct.
      - apply JumpTarget_Realise.
      - apply TailRec_Realise.
      - apply ConsClos_Realise.
    }
    {
      intros tin (yout, tout) H. cbn. intros T V heap a P s0 s1 s2 s3 s4 sr HEncT HEncV HEncHeap HEncP HEncA HInt.
      specializeFin HInt. clear HInt.
      destruct H; TMSimp.
      { (* Then, i.e. [jumpTarget 0 [] = Some (Q', P')] *)
        rename H into HJumpTarget, H1 into HTailRec, H3 into HConsClos.
        modpon HJumpTarget.
        {
          instantiate (1 := [| _;_;_|]).
          intros i; destruct_fin i;cbn;simpl_surject;isVoid_mono.
        }
        destruct HJumpTarget as (P'&Q'&HJumpTarget); modpon HJumpTarget.
        unfold Step_lam_size; rewrite HJumpTarget.
        modpon HTailRec.
        modpon HConsClos.
        do 2 eexists; repeat split; eauto.
        specializeFin HJumpTarget2. clear HJumpTarget2.
        cbn; TMSimp_goal. unfold id.
        intros. simpl_surject.
        destruct_fin i; TMSimp; cbn in *;auto.
      }
      { (* Else, i.e. [jumpTarget 0 [] = None] *)
        modpon H.
        { instantiate (1 := [| _;_;_|]).
          intros i; destruct_fin i; cbn; simpl_surject; auto. }
        assumption.
      }
    }
  Qed.

  (* Steps depending on the result of [JumpTarget] *)
  Definition Step_lam_steps_JumpTarget P a :=
    match jumpTarget 0 [] P with
    | Some (Q', P') =>
      1 + TailRec_steps P' a + ConsClos_steps Q' a
    | None => 0
    end.

  Definition Step_lam_steps P a := 1 + JumpTarget_steps P + Step_lam_steps_JumpTarget P a.

  Definition Step_lam_T : tRel sigStep^+ 10 :=
    fun tin k =>
      exists (T V : list HClos) (H : Heap) (a : HAdd) (P : Pro),
        tin[@Fin0] ≃ T /\
        tin[@Fin1] ≃ V /\
        tin[@Fin2] ≃ H /\
        tin[@Fin3] ≃(retr_pro_step) P /\
        tin[@Fin4] ≃(retr_nat_step_clos_ad) a /\
        (forall i : Fin.t 5, isVoid tin[@FinR 5 i]) /\
        Step_lam_steps P a <= k.

  Lemma Step_lam_Terminates : projT1 Step_lam ↓ Step_lam_T.
  Proof.
    eapply TerminatesIn_monotone.
    { unfold Step_lam. TM_Correct.
      - apply JumpTarget_Realise.
      - apply JumpTarget_Terminates.
      - apply TailRec_Realise.
      - apply TailRec_Terminates.
      - apply ConsClos_Terminates.
    }
    {
      intros tin k. intros (T&V&H&a&P&HEncT&HEncV&HEncH&HEncP&HEncA&HInt&Hk).
      specializeFin HInt. clear HInt.
      unfold Step_lam_steps in Hk.
      exists (JumpTarget_steps P), (Step_lam_steps_JumpTarget P a). cbn; repeat split; try lia.
      { hnf; cbn. do 1 eexists; repeat split; simpl_surject; eauto. intros i; destruct_fin i;cbn;simpl_surject;easy. }
      intros tmid ymid (HJump&HJumpInj); TMSimp. modpon HJump.
      {
        instantiate (1 := [| _;_;_|]).
        intros i. destruct_fin i; cbn; simpl_surject; TMSimp_goal; isVoid_mono.
      }
      destruct ymid.
      {
        destruct HJump as (P'&Q'&HJump); modpon HJump.
        unfold Step_lam_steps_JumpTarget. rewrite HJump.
        exists (TailRec_steps P' a), (ConsClos_steps Q' a). cbn; repeat split; try lia. hnf; cbn; eauto 7.
        intros tmid0 () (HTailRec&HTailRecInj); TMSimp. modpon HTailRec.
        hnf; cbn. eauto 7.
      }
      { lia. }
    }
  Qed.

  Definition Put_size (H : Heap) (g : HClos) (b : HAdd) : Vector.t (nat->nat) 6 :=
    (*
    (Length_size H @>> [|Fin0; Fin3; Fin4; Fin5|]) >>>
    ([|pred|] @>> [|Fin4|]) >>> (* nil *)
    ([|Constr_pair_size g >> pred|] @>>[|Fin2|]) >>> (* pair and [Some] on tape 2 *)
     ...
    *)
    [| (*0*) Length_size H @>Fin0 >> MoveValue_size_y (H++[Some(g,b)]) H;
       (*1*) Reset_size g;
       (*2*) Constr_pair_size g >> pred >> Reset_size (Some(g,b));
       (*3*) Length_size H @>Fin1;
       (*4*) Length_size H @>Fin2 >> pred >> Constr_cons_size (Some(g,b)) >> App'_size H >> MoveValue_size_x (H++[Some(g,b)]); (* nil and cons *)
       (*5*) Length_size H @>Fin3
     |].

  Definition Put_Rel : pRel sigStep^+ unit 6 :=
    ignoreParam (
        fun tin tout =>
          forall (H : Heap) (g : HClos) (b : HAdd) (s0 s1 s2 s3 s4 s5 : nat),
            let size := Put_size H g b in
            tin[@Fin0] ≃(;s0) H ->
            tin[@Fin1] ≃(retr_clos_step;s1) g ->
            tin[@Fin2] ≃(retr_nat_step_clos_ad;s2) b ->
            isVoid_size tin[@Fin3] s3 -> isVoid_size tin[@Fin4] s4 -> isVoid_size tin[@Fin5] s5 ->
            tout[@Fin0] ≃(;size @>Fin0 s0) H ++ [Some (g,b)] /\
            isVoid_size tout[@Fin1] (size @>Fin1 s1) /\
            isVoid_size tout[@Fin2] (size @>Fin2 s2) /\
            tout[@Fin3] ≃(retr_nat_step_clos_ad; size @>Fin3 s3) length H /\
            isVoid_size tout[@Fin4] (size @>Fin4 s4) /\
            isVoid_size tout[@Fin5] (size @>Fin5 s5)
      ).

  Local Definition retr_nat_step_hent : Retract sigNat sigStep := ComposeRetract retr_heap_step retr_nat_heap_entry.

  Local Definition retr_clos_step_hent : Retract sigHClos sigStep := ComposeRetract retr_heap_step retr_clos_heap.

  Local Definition retr_hent'_step : Retract sigHEntr' sigStep := ComposeRetract retr_heap_step retr_hent'_heap.

  Local Definition retr_hent_step : Retract sigHEntr sigStep := ComposeRetract retr_heap_step retr_hent_heap.

  Definition Put : pTM sigStep^+ unit 6 :=
    Length retr_heap_step retr_nat_step_clos_ad @ [|Fin0; Fin3; Fin4; Fin5|];;
    Constr_nil HEntr ⇑ _ @ [|Fin4|];;
    Translate retr_nat_step_clos_ad retr_nat_step_hent @ [|Fin2|];;
    Translate retr_clos_step retr_clos_step_hent @ [|Fin1|];;
    Constr_pair sigHClos_fin sigHAdd_fin ⇑ retr_hent'_step @ [|Fin1; Fin2|];;
    Constr_Some sigHEntr'_fin ⇑ retr_hent_step @ [|Fin2|];;
    Constr_cons sigHEntr_fin ⇑ _ @ [|Fin4; Fin2|];;
    App' sigHEntr_fin ⇑ _ @ [|Fin0; Fin4|];;
    MoveValue _ @ [|Fin4; Fin0|];;
    Reset _ @ [|Fin2|];;
    Reset _ @ [|Fin1|].

  Lemma Put_Realise : Put ⊨ Put_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold Put. TM_Correct.
      - apply Length_Computes with (X := HEntr).
      - apply App'_Realise with (X := HEntr).
    }
    {
      intros tin ((), tout) H. cbn. intros heap g b s0 s1 s2 s3 s4 s5 HEncHeap HEncG HEncB HRigh3 HRight4 HRight5.
      TMSimp. (* This takes long *)
      rename H into HLength; rename H0 into HNil; rename H2 into HTranslate;
      rename H4 into HTranslate'; rename H6 into HPair; rename H8 into HSome; rename H10 into HCons;
       rename H12 into HApp; rename H14 into HMove; rename H16 into HReset; rename H18 into HReset'.
      modpon HLength.
      (* { intros i; destruct_fin i; TMSimp_goal; auto. } *)
      (* specialize (HLength1 Fin1) as HLength2; specialize (HLength1 Fin0). *)
      modpon HNil.
      modpon HTranslate.
      modpon HTranslate'.
      modpon HPair.
      specialize (HSome (g, b)). modpon HSome. cbn in *.
      specialize (HCons [] (Some (g, b))). modpon HCons.
      modpon HApp.
      modpon HMove.
      specialize HReset with (x := (Some (g, b))). modpon HReset.
      modpon HReset'.
      repeat split; auto.
    }
  Qed.

  Local Arguments Put_size : simpl never.

  Definition Put_steps H g b :=
    10 + Length_steps H + Constr_nil_steps + Translate_steps b + Translate_steps g + Constr_pair_steps g + Constr_Some_steps +
    Constr_cons_steps (Some (g, b)) + App'_steps H + MoveValue_steps (H++[Some(g,b)]) H + Reset_steps (Some (g, b)) + Reset_steps g.

  Definition Put_T : tRel sigStep ^+ 6 :=
    fun tin k =>
      exists (H : Heap) (g : HClos) (b : HAdd),
        tin[@Fin0] ≃ H /\
        tin[@Fin1] ≃(retr_clos_step) g /\
        tin[@Fin2] ≃(retr_nat_step_clos_ad) b /\
        isVoid tin[@Fin3] /\ isVoid tin[@Fin4] /\ isVoid tin[@Fin5] /\
        Put_steps H g b <= k.

  Lemma Put_Terminates : projT1 Put ↓ Put_T.
  Proof.
    eapply TerminatesIn_monotone.
    { unfold Put. TM_Correct.
      - apply Length_Computes with (X := HEntr).
      - apply Length_Terminates with (X := HEntr).
      - apply App'_Realise with (X := HEntr).
      - apply App'_Terminates with (X := HEntr).
    }
    {
      intros tin k. intros (H&g&b&HEncH&HEncG&HEncB&HRight3&HRight4&HRight5&Hk). unfold Put_steps in Hk.
      exists (Length_steps H),
      (1 + Constr_nil_steps + 1 + Translate_steps b + 1 + Translate_steps g + 1 + Constr_pair_steps g + 1 + Constr_Some_steps +
       1 + Constr_cons_steps (Some (g, b)) + 1 + App'_steps H + 1 + MoveValue_steps (H++[Some(g,b)]) H + 1 + Reset_steps (Some (g, b)) +
       Reset_steps g).
      cbn; repeat split; try lia. now hnf; cbn; eauto 10.
      intros tmid_ () (HLength&HLengthInj); TMSimp. modpon HLength.
      exists (Constr_nil_steps),
      (1 + Translate_steps b + 1 + Translate_steps g + 1 + Constr_pair_steps g + 1 + Constr_Some_steps +
       1 + Constr_cons_steps (Some (g, b)) + 1 + App'_steps H + 1 + MoveValue_steps (H++[Some(g,b)]) H + 1 + Reset_steps (Some (g, b)) +
       Reset_steps g).
      cbn; repeat split; try lia.
      intros tmid0_ () (HNil&HNilInj); TMSimp. modpon HNil. simpl_surject.
      exists (Translate_steps b),
      (1 + Translate_steps g + 1 + Constr_pair_steps g + 1 + Constr_Some_steps + 1 + Constr_cons_steps (Some (g, b)) +
       1 + App'_steps H + 1 + MoveValue_steps (H++[Some(g,b)]) H + 1 + Reset_steps (Some (g, b)) + Reset_steps g).
      cbn; repeat split; try lia. now hnf; cbn; eexists; split; eauto.
      intros tmid1_ () (HTranslate&HTranslateInj); TMSimp. modpon HTranslate.
      exists (Translate_steps g),
      (1 + Constr_pair_steps g + 1 + Constr_Some_steps + 1 + Constr_cons_steps (Some (g, b)) +
       1 + App'_steps H + 1 + MoveValue_steps (H++[Some(g,b)]) H + 1 + Reset_steps (Some (g, b)) + Reset_steps g).
      cbn; repeat split; try lia. now hnf; cbn; eauto.
      intros tmid2_ () (HTranslate'&HTranslateInj'); TMSimp. modpon HTranslate'.
      exists (Constr_pair_steps g),
      (1 + Constr_Some_steps + 1 + Constr_cons_steps (Some (g, b)) +
       1 + App'_steps H + 1 + MoveValue_steps (H++[Some(g,b)]) H + 1 + Reset_steps (Some (g, b)) + Reset_steps g).
      cbn; repeat split; try lia.
      { hnf; cbn; eexists; split; simpl_surject; eauto; contains_ext. }
      intros tmid3_ () (HPair&HPairInj); TMSimp. modpon HPair.
      exists (Constr_Some_steps),
      (1 + Constr_cons_steps (Some (g, b)) + 1 + App'_steps H + 1 + MoveValue_steps (H++[Some(g,b)]) H + 1 +
       Reset_steps (Some (g, b)) + Reset_steps g).
      cbn; repeat split; try lia.
      intros tmid4_ () (HSome&HSomeInj); TMSimp. specialize (HSome (g,b)); modpon HSome.
      exists (Constr_cons_steps (Some (g, b))),
         (1 + App'_steps H + 1 + MoveValue_steps (H++[Some(g,b)]) H + 1 + Reset_steps (Some (g, b)) + Reset_steps g).
      cbn; repeat split; try lia.
      { do 2 eexists; repeat split; simpl_surject; eauto. }
      intros tmid5_ () (HCons&HConsInj); TMSimp. specialize (HCons [] (Some (g,b))); modpon HCons.
      exists (App'_steps H), (1 + MoveValue_steps (H++[Some(g,b)]) H + 1 + Reset_steps (Some (g, b)) + Reset_steps g).
      cbn; repeat split; try lia.
      { hnf; cbn. do 2 eexists; repeat split; simpl_surject; eauto. }
      intros tmid6_ () (HApp&HAppInj); TMSimp. modpon HApp.
      exists (MoveValue_steps (H++[Some(g,b)]) H), (1 + Reset_steps (Some (g, b)) + Reset_steps g).
      cbn; repeat split; try lia.
      { hnf; cbn. do 2 eexists; repeat split; simpl_surject; eauto. }
      intros tmid7_ () (HMove&HMoveInj); TMSimp. modpon HMove.
      exists (Reset_steps (Some (g, b))), (Reset_steps g).
      cbn; repeat split; try lia.
      { hnf; cbn. exists (Some (g, b)). split; eauto. }
      intros tmid8_ () (HReset&HResetInj); TMSimp. specialize HReset with (x := (Some (g,b))); modpon HReset.
      { hnf; cbn. exists g. repeat split; eauto. }
    }
  Qed.

  (* This time I write the size function column-wise *)
  Definition Step_app_size (T V : list HClos) (H : Heap) (a : HAdd) (P : Pro) : Vector.t (nat->nat) 11 :=
    match V with
    | g :: (b, Q) :: V' =>
      ([|CaseList_size0 g; CaseList_size1 g|] @>> [|Fin1;Fin5|]) >>>
      ([|CaseList_size0 (b,Q); CaseList_size1 (b,Q)|] @>> [|Fin1;Fin6|]) >>>
      ([|CasePair_size0 b; CasePair_size1 b|] @>> [|Fin6;Fin7|]) >>>
      (TailRec_size T P a @>> [|Fin0; Fin3; Fin4|]) >>>
      ([|Reset_size a|] @>> [|Fin4|]) >>>
      (Put_size H g b @>> [|Fin2; Fin5; Fin7; Fin8; Fin9; Fin10|]) >>>
      (ConsClos_size (tailRecursion (a,P) T) Q (length H) @>> [|Fin0; Fin8; Fin6|])
    | _ => default (* not specified *)
    end.

  Definition Step_app_Rel : pRel sigStep^+ bool 11 :=
    fun tin '(yout, tout) =>
      forall (T V : list HClos) (H : Heap) (a : HAdd) (P : Pro) (s0 s1 s2 s3 s4 : nat) (sr : Vector.t nat 6),
        let size := Step_app_size T V H a P in
        tin[@Fin0] ≃(;s0) T ->
        tin[@Fin1] ≃(;s1) V ->
        tin[@Fin2] ≃(;s2) H ->
        tin[@Fin3] ≃(retr_pro_step;s3) P ->
        tin[@Fin4] ≃(retr_nat_step_clos_ad;s4) a ->
        (forall i : Fin.t 6, isVoid_size tin[@FinR 5 i] sr[@i]) ->

        match yout, V with
        | true, g :: (b, Q) :: V =>
          let (c, H') := put H (Some (g, b)) in (* This simplifys immediatly by computation *)
          tout[@Fin0] ≃(;size@>Fin0 s0) (c, Q) :: tailRecursion (a, P) T /\
          tout[@Fin1] ≃(;size@>Fin1 s1) V /\
          tout[@Fin2] ≃(;size@>Fin2 s2) H' /\
          (forall i : Fin.t 8, isVoid_size tout[@FinR 3 i] (size @>(FinR 3 i) (s3:::s4:::sr)[@i]))
        | false, [] => True
        | false, [_] => True
        | _, _ => False
        end.

  Definition Step_app : pTM sigStep^+ bool 11 :=
    If (CaseList sigHClos_fin ⇑ _ @ [|Fin1; Fin5|])
       (If (CaseList sigHClos_fin ⇑ _ @ [|Fin1; Fin6|])
           (Return (CasePair sigHAdd_fin sigPro_fin ⇑ retr_clos_step @ [|Fin6; Fin7|];;
                    TailRec @ [|Fin0; Fin3; Fin4|];;
                    Reset _ @ [|Fin4|];;
                    Put @ [|Fin2; Fin5; Fin7; Fin8; Fin9; Fin10|];;
                    ConsClos @ [|Fin0; Fin8; Fin6|])
                   (true))
           (Return Nop false))
       (Return Nop false)
  .

  Arguments Step_app_size : simpl never.

  Lemma Step_app_Realise : Step_app ⊨ Step_app_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold Step_app. TM_Correct.
      - apply TailRec_Realise.
      - apply Put_Realise.
      - apply ConsClos_Realise.
    }
    {
      intros tin (yout, tout) H. cbn. intros T V heap a P s0 s1 s2 s3 s4 sr HEncT HEncV HEncH HEncP HEncA HInt.
      TMSimp. rename H into HIf.
      destruct HIf; TMSimp.
      { (* Then of first [CaseList], i.e. [V = g :: V'] *) rename H into HCaseList, H0 into HIf'.
        specialize (HInt Fin0) as ?. specialize (HInt Fin1) as ?. specialize (HInt Fin2) as ?.
        specialize (HInt Fin3) as ?. specialize (HInt Fin4) as ?. specialize (HInt Fin5) as ?. clear HInt. cbn in *.
        modpon HCaseList.
        destruct V as [ | g V']; auto; modpon HCaseList.
        destruct HIf'; TMSimp. (* This takes VERY long *)
        {
          rename H5 into HCaseList'; rename H7 into HCasePair; rename H9 into HTailRec;
          rename H11 into HReset; rename H13 into HPut; rename H15 into HConsClos.
          modpon HCaseList'. cbn in *.
          destruct V' as [ | (b, Q) V'']; auto. modpon HCaseList'.
          specialize (HCasePair (b,Q)). modpon HCasePair. cbn in *.
          modpon HTailRec.
          modpon HReset.
          modpon HPut.
          modpon HConsClos.
          repeat split; auto.
          - intros i; destruct_fin i; cbn; auto; TMSimp_goal; auto.
        }
        { modpon H5. destruct V'; auto. }
      }
      { specialize (HInt Fin0). modpon H. destruct V; auto. }
    }
  Qed.

  Arguments Step_app_size : simpl never.

  Definition Step_app_steps_CaseList' g V' H P a :=
    match V' with
    | nil => 0 (* Nop *)
    | (b, Q) :: V'' =>
      4 + CasePair_steps b + TailRec_steps P a + Reset_steps a + Put_steps H g b + ConsClos_steps Q (length H)
    end.

  Definition Step_app_steps_CaseList V H P a :=
    match V with
    | nil => 0 (* Nop *)
    | g :: V' => 1 + CaseList_steps V' + Step_app_steps_CaseList' g V' H P a
    end.

  Definition Step_app_steps V H a P := 1 + CaseList_steps V + Step_app_steps_CaseList V H P a.

  Definition Step_app_T : tRel sigStep^+ 11 :=
    fun tin k =>
      exists (T V : list HClos) (H : Heap) (P : Pro) (a : HAdd),
        tin[@Fin0] ≃ T /\
        tin[@Fin1] ≃ V /\
        tin[@Fin2] ≃ H /\
        tin[@Fin3] ≃(retr_pro_step) P /\
        tin[@Fin4] ≃(retr_nat_step_clos_ad) a /\
        (forall i : Fin.t 6, isVoid tin[@FinR 5 i]) /\
        Step_app_steps V H a P <= k.

  Lemma Step_app_Terminates : projT1 Step_app ↓ Step_app_T.
  Proof.
    eapply TerminatesIn_monotone.
    { unfold Step_app. TM_Correct.
      - apply TailRec_Realise.
      - apply TailRec_Terminates.
      - apply Put_Realise.
      - apply Put_Terminates.
      - apply ConsClos_Terminates.
    }
    {
      intros tin k. intros (T&V&H&P&a&HEncT&HEncV&HEncH&HEncP&HEncA&HInt&Hk). unfold Step_app_steps in Hk.
      exists (CaseList_steps V), (Step_app_steps_CaseList V H P a).
      cbn; repeat split; try lia.
      { exists V. repeat split; simpl_surject; eauto. apply HInt. }
      intros tmid_ bml1 (HCaseList&HCaseListInj); TMSimp.
      specialize (HInt Fin0) as ?.
      specialize (HInt Fin1) as ?.
      specialize (HInt Fin2) as ?.
      specialize (HInt Fin3) as ?.
      specialize (HInt Fin4) as ?.
      specialize (HInt Fin5) as ?.

      modpon HCaseList.
      destruct bml1, V as [ | g V']; auto; modpon HCaseList.
      {
        unfold Step_app_steps_CaseList.
        exists (CaseList_steps V'), (Step_app_steps_CaseList' g V' H P a).
        cbn; repeat split; try lia.
        { exists V'. repeat split; simpl_surject; eauto. }
        intros tmid1_ bml2 (HCaseList'&HCaseListInj'); TMSimp. modpon HCaseList'.
        destruct bml2, V' as [ | (b, Q) V'']; auto; modpon HCaseList'.
        {
          unfold Step_app_steps_CaseList'.
          exists (CasePair_steps b), (1 + TailRec_steps P a + 1 + Reset_steps a + 1 + Put_steps H g b + ConsClos_steps Q (length H)).
          cbn; repeat split; try lia.
          { hnf; cbn. exists (b, Q). repeat split; simpl_surject; eauto. }
          intros tmid2_ () (HCasePair&HCasePairInj); TMSimp. specialize (HCasePair (b,Q)); modpon HCasePair.
          exists (TailRec_steps P a), (1 + Reset_steps a + 1 + Put_steps H g b + ConsClos_steps Q (length H)).
          cbn; repeat split; try lia.
          { hnf; cbn. do 3 eexists. repeat split; simpl_surject; eauto. }
          intros tmid3_ () (HTailRec&HTailRecInj); TMSimp. modpon HTailRec.
          exists (Reset_steps a), (1 + Put_steps H g b + ConsClos_steps Q (length H)).
          cbn; repeat split; try lia.
          { hnf; cbn. do 1 eexists. repeat split; simpl_surject; eauto. }
          intros tmid4_ () (HReset&HResetInj); TMSimp. modpon HReset.
          exists (Put_steps H g b), (ConsClos_steps Q (length H)).
          cbn; repeat split; try lia.
          { hnf; cbn. do 3 eexists. repeat split; simpl_surject; eauto; contains_ext. }
          intros tmid5_ () (HPut&HInjPut); TMSimp. modpon HPut.
          { hnf; cbn. do 3 eexists. repeat split; simpl_surject; eauto; contains_ext. }
        }
      }
    }
  Qed.

  Definition Step_var_size (T V : list HClos) (H : Heap) (a : HAdd) (n : nat) (P : Pro) : Vector.t (nat->nat) 8 :=
    match lookup H a n with
    | Some g =>
      (TailRec_size T P a @>> [|Fin0; Fin3; Fin4|]) >>>
      (Lookup_size H a n @>> [|Fin2; Fin4; Fin5; Fin6; Fin7|]) >>>
      ([|Constr_cons_size g; Reset_size g|] @>> [|Fin1; Fin6|])
    | None => default
    end.

  Definition Step_var_Rel : pRel sigStep^+ bool 8 :=
    fun tin '(yout, tout) =>
      forall (T V : list HClos) (H : Heap) (a : HAdd) (n : nat) (P : Pro) (s0 s1 s2 s3 s4 s5 s6 s7 : nat),
        let size := Step_var_size T V H a n P in
        tin[@Fin0] ≃(;s0) T ->
        tin[@Fin1] ≃(;s1) V ->
        tin[@Fin2] ≃(;s2) H ->
        tin[@Fin3] ≃(retr_pro_step;s3) P ->
        tin[@Fin4] ≃(retr_nat_step_clos_ad;s4) a ->
        tin[@Fin5] ≃(retr_nat_step_clos_var;s5) n ->
        isVoid_size tin[@Fin6] s6 -> isVoid_size tin[@Fin7] s7 ->
        match yout with
        | true =>
          exists (g : HClos),
          lookup H a n = Some g /\
          tout[@Fin0] ≃(;size@>Fin0 s0) tailRecursion (a, P) T /\
          tout[@Fin1] ≃(;size@>Fin1 s1) g :: V /\
          tout[@Fin2] ≃(;size@>Fin2 s2) H /\
          (forall i : Fin.t 5, isVoid_size tout[@FinR 3 i] (size @>(FinR 3 i) [|s3;s4;s5;s6;s7|][@i]))
        | false => lookup H a n = None
        end
  .

  Definition Step_var : pTM sigStep^+ bool 8 :=
    TailRec @ [|Fin0; Fin3; Fin4|];;
    If (Step_Lookup @ [|Fin2; Fin4; Fin5; Fin6; Fin7|])
       (Return (Constr_cons sigHClos_fin ⇑ _ @ [|Fin1; Fin6|];;
                Reset _ @ [|Fin6|])
               (true))
       (Return Nop false).

  Local Definition retr_closure_step : Retract sigHClos sigStep := ComposeRetract retr_closures_step _.

  Lemma Step_var_Realise : Step_var ⊨ Step_var_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold Step_var. TM_Correct.
      - apply TailRec_Realise.
      - apply Lookup_Realise.
    }
    {
      intros tin (yout, tout) H. cbn. intros T V heap a n P s0 s1 s2 s3 s4 s5 s6 s7 HEncT HEncV HEncHeap HEncP HEncA HEncN HRight6 HRight7.
      unfold Step_var_size.
      TMSimp. rename H into HTailRec, H0 into HIf.
      modpon HTailRec.
      destruct HIf; TMSimp.
      { rename H into HLookup, H1 into HCons, H3 into HReset.
        modpon HLookup. destruct HLookup as (g&HLookup); modpon HLookup. rewrite HLookup.
        modpon HCons. modpon HReset.
        eexists; repeat split; eauto.
        - intros i; destruct_fin i; auto; TMSimp_goal; cbn; rewrite !vector_tl_nth; auto.
      }
      { now modpon H. }
    }
  Qed.

  Local Arguments Step_var_size : simpl never.

  Definition Step_var_steps_Lookup H a n :=
    match lookup H a n with
    | None => 0 (* Nop *)
    | Some g => 1 + Constr_cons_steps g + Reset_steps g
    end.

  Definition Step_var_steps P H a n := 2 + TailRec_steps P a + Lookup_steps H a n + Step_var_steps_Lookup H a n.

  Definition Step_var_T : tRel sigStep^+ 8 :=
    fun tin k =>
      exists (T V : list HClos) (H : Heap) (a : HAdd) (n : nat) (P : Pro),
        tin[@Fin0] ≃ T /\
        tin[@Fin1] ≃ V /\
        tin[@Fin2] ≃ H /\
        tin[@Fin3] ≃(retr_pro_step) P /\
        tin[@Fin4] ≃(retr_nat_step_clos_ad) a /\
        tin[@Fin5] ≃(retr_nat_step_clos_var) n /\
        isVoid tin[@Fin6] /\ isVoid tin[@Fin7] /\
        Step_var_steps P H a n <= k.

  Lemma Step_var_Terminates : projT1 Step_var ↓ Step_var_T.
  Proof.
    eapply TerminatesIn_monotone.
    { unfold Step_var. TM_Correct.
      - apply TailRec_Realise.
      - apply TailRec_Terminates.
      - apply Lookup_Realise.
      - apply Lookup_Terminates.
    }
    {
      intros tin k. intros (T&V&H&a&n&P&HEncT&HEncV&HEncH&HEncP&HEncA&HEncN&HRight6&HRigth7&Hk). unfold Step_var_steps in Hk.
      exists (TailRec_steps P a), (1 + Lookup_steps H a n + Step_var_steps_Lookup H a n).
      cbn; repeat split; try lia.
      { hnf; cbn. do 3 eexists; repeat split; eauto. }
      intros tmid_ () (HTailRec&HTailRecInj); TMSimp. modpon HTailRec.
      exists (Lookup_steps H a n), (Step_var_steps_Lookup H a n).
      cbn; repeat split; try lia.
      { hnf; cbn. do 3 eexists; repeat split; eauto. }
      intros tmid0_ ymid (HLookup&HLookupInj); TMSimp. modpon HLookup.
      destruct ymid.
      {
        destruct HLookup as (g&HLookup); modpon HLookup.
        unfold Step_var_steps_Lookup. rewrite HLookup.
        exists (Constr_cons_steps g), (Reset_steps g).
        cbn; repeat split; try lia.
        { hnf; cbn. do 2 eexists; repeat split; simpl_surject; eauto. }
        intros tmid1 () (HCons&HConsInj); TMSimp. modpon HCons.
        { hnf; cbn. do 1 eexists; repeat split; simpl_surject; eauto. }
      }
      { lia. }
    }
  Qed.

  (* I forgot that [While] takes a machine over [option unit] instead of [bool]. But that's no problem since we have [Relabel]. *)
  Local Coercion bool2optunit := fun b : bool => if b then None else Some tt.

  Definition Step : pTM sigStep^+ (option unit) 11 :=
    Relabel
      (If (CaseList sigHClos_fin ⇑ _ @ [|Fin0; Fin3|])
          (CasePair sigHAdd_fin sigPro_fin ⇑ retr_clos_step @ [|Fin3; Fin4|];;
           If (CaseList sigCom_fin ⇑ retr_pro_step @ [|Fin3; Fin5|])
              (Switch (CaseCom ⇑ retr_tok_step @ [|Fin5|])
                     (fun t : option ACom =>
                        match t with
                        | Some lamAT =>
                          Step_lam @ [|Fin0; Fin1; Fin2; Fin3; Fin4; Fin5; Fin6; Fin7; Fin8; Fin9|]
                        | Some appAT =>
                          Step_app
                        | Some retAT =>
                          Return Nop false
                        | None (* Variable *) =>
                          Step_var @ [|Fin0; Fin1; Fin2; Fin3; Fin4; Fin5; Fin6; Fin7|]
                        end))
              (Return Nop false))
          (Return Nop false)
        ) bool2optunit.

  Definition Step_size (T V : list HClos) (H : Heap) : Vector.t (nat->nat) 11 :=
    match T with
    | (a, (t :: P)) :: T' =>
      (* Common steps: destruct [T] (on tapes 0, 3, 4, 5) *)
      ([| (*0*) CaseList_size0 (a, (t::P));
          (*3*) CaseList_size1 (a, (t::P)) >> CasePair_size0 a >> CaseList_size0 t;
          (*4*) CasePair_size1 a;
          (*5*) CaseList_size1 t >> CaseCom_size t |]
         @>> [|Fin0; Fin3; Fin4; Fin5|]) >>>
      (match t with
       | lamT => Step_lam_size T' V H a P @>> [|Fin0; Fin1; Fin2; Fin3; Fin4; Fin5; Fin6; Fin7; Fin8; Fin9|]
       | appT => Step_app_size T' V H a P
       | retT => default (* not specified *)
       | varT n => Step_var_size T' V H a n P @>> [|Fin0; Fin1; Fin2; Fin3; Fin4; Fin5; Fin6; Fin7|]
       end)
    | _ => Vector.const id _
    end.

  Definition Step_Rel : pRel sigStep^+ (option unit) 11 :=
    fun tin '(yout, tout) =>
      forall (T V : list HClos) (H: Heap) (s0 s1 s2 : nat) (sr : Vector.t nat 8),
        let size := Step_size T V H in
        tin[@Fin0] ≃(;s0) T ->
        tin[@Fin1] ≃(;s1) V ->
        tin[@Fin2] ≃(;s2) H ->
        (forall i : Fin.t 8, isVoid_size tin[@FinR 3 i] (sr[@i])) ->
        match yout with
        | None =>
          exists T' V' H',
          step (T,V,H) (T',V',H') /\
          tout[@Fin0] ≃(;size@>Fin0 s0) T' /\
          tout[@Fin1] ≃(;size@>Fin1 s1) V' /\
          tout[@Fin2] ≃(;size@>Fin2 s2) H' /\
          (forall i : Fin.t 8, isVoid_size tout[@FinR 3 i] (size@>(FinR 3 i) sr[@i]))
        | Some tt =>
          halt_state (T,V,H) /\
          match T with
          | nil =>
            tout[@Fin0] ≃(;size@>Fin0 s0) (@nil HClos) /\
            tout[@Fin1] ≃(;size@>Fin1 s1) V /\
            tout[@Fin2] ≃(;size@>Fin2 s2) H /\
            (forall i : Fin.t 8, isVoid_size tout[@FinR 3 i] (size@>(FinR 3 i) sr[@i]))
          | _ => True
          end
        end.

  Arguments Step_size : simpl never.
  Opaque Step_app_size.

  Lemma Step_Realise : Step ⊨ Step_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold Step. TM_Correct.
      - eapply RealiseIn_Realise. apply CaseCom_Sem.
      - apply Step_lam_Realise.
      - apply Step_app_Realise.
      - apply Step_var_Realise.
    }
    {
      intros tin (yout, tout) H. cbn. intros T V Heap s0 s1 s2 sr HEncT HEncV HEncHeap HInt.
      TMSimp. rename H0 into HIf.
      destruct HIf; TMSimp.
      { (* Then of [CaseList], i.e. [T = (a, P) :: T'] *) rename H into HCaseList, H0 into HCasePair, H2 into HIf'.
      do_n_times_fin 8 ltac:(fun i => let H := fresh "H" in specialize (HInt i) as H;cbn in H);clear HInt.
      modpon HCaseList;[]. destruct T as [ | (a, P) T' ]; auto;[]. modpon HCaseList;[].
      specialize (HCasePair (a, P)); modpon HCasePair;[].
      destruct HIf'; TMSimp.
      { (* Then of second [CaseList], i.e [P = t :: P'] *) rename H7 into HCaseList', H8 into HCaseCom, H10 into HCase.
        modpon HCaseList'. destruct P as [ | t P']; auto; modpon HCaseList'.
        modpon HCaseCom. rename ymid0 into c.
        destruct c as [ [ | | ] | ]; auto; simpl_surject; cbn in *.
        1-3:destruct HCaseCom as [HCaseCom <-].
        { (* retT *)
          destruct HCase as (->&(?&[=])); cbn;subst. split; auto. hnf. intros s HStep. inv HStep.
        }
          { (* lamT *)
            rename HCase into HStepLam. modpon HStepLam; TMSimp_goal; eauto; try contains_ext.
            { instantiate (1 := [| _;_;_;_;_|]).
              intros i; destruct_fin i; auto; TMSimp_goal; cbn. all:eauto.
            }
            destruct ymid.
            - cbn. destruct HStepLam as (jump_P&jump_Q&HStepLam); modpon HStepLam.
              do 3 eexists. unfold Step_size;cbn. repeat split; eauto.
              + econstructor. eauto.
              + generalize (HStepLam4 Fin0); generalize (HStepLam4 Fin1); generalize (HStepLam4 Fin2); generalize (HStepLam4 Fin3); generalize (HStepLam4 Fin4); generalize (HStepLam4 Fin5); generalize (HStepLam4 Fin6); cbn; TMSimp_goal; intros.
                cbn.
                specialize (HStepLam0 Fin10) as H'. cbn in H'. revert H'. intros -> . 2:now vector_not_in.
                destruct_fin i; TMSimp_goal; cbn; auto; try rewrite HStepLam0 by vector_not_in; TMSimp_goal; try rewrite !vector_tl_nth; auto.
            - cbn. split; auto. intros s' HStep. inv HStep. congruence.
          }
          { (* appT *)
            rename HCase into HStepApp. cbn in HStepApp.
            cbv [put] in *. modpon HStepApp; TMSimp_goal; eauto; try contains_ext.
            { instantiate (1 := [| _;_;_;_;_;_|]).
              intros i; destruct_fin i; auto; TMSimp_goal. all:cbn;eauto.
            }
            destruct ymid; cbn.
            - destruct V as [ | g V']; auto.
              destruct V' as [ | (b, Q) V'']; auto. modpon HStepApp;[].

              do 3 eexists. repeat split.
               +econstructor;reflexivity.
               +abstract (vm_cast_no_check HStepApp).
               +abstract (vm_cast_no_check HStepApp0).
               +abstract (vm_cast_no_check HStepApp1).
               +abstract (intros i; specialize (HStepApp2 i);cbv delta [Step_size]; cbn in *;unfold Step_size; destruct_fin i; cbn; assumption).
            - split; auto. intros s' HStep. now inv HStep.
          }
          { (* varT *)
            destruct HCaseCom as (n&->&HCaseCom).
            rename HCase into HStepVar. modpon HStepVar; TMSimp_goal; eauto; try contains_ext.
            destruct ymid; cbn.
            - destruct HStepVar as (g&HStepVar); modpon HStepVar.
              do 3 eexists; repeat split; eauto.
              + econstructor; eauto.
              + generalize (HStepVar4 Fin0); generalize (HStepVar4 Fin1); generalize (HStepVar4 Fin2); generalize (HStepVar4 Fin3); generalize (HStepVar4 Fin4); cbn; TMSimp_goal; intros.
                simpl_not_in. destruct_fin i; cbn; auto; TMSimp_goal; auto.
            - split; auto. intros s' HStep. inv HStep. congruence.
          }
        }
        { (* Else of the second [CaseList], i.e [P = nil] *)
          modpon H7. destruct P; auto. split; auto. intros s HStep. now inv HStep.
        }
      }
      { (* Else of the first [CaseList], i.e. [T = nil] *)
        specializeFin HInt. clear HInt.
        modpon H. destruct T; auto. modpon H. split; auto. intros s HStep. now inv HStep.
        repeat split; eauto.
        abstract (intros i; destruct_fin i; TMSimp_goal; cbn in *; auto).
      }
    }
  Qed.

  Global Arguments Step_size : simpl never.

  Definition Step_steps_CaseCom a t P' V H :=
    match t with
    | varT n => Step_var_steps P' H a n
    | appT => Step_app_steps V H a P'
    | lamT => Step_lam_steps P' a
    | retT => 0 (* Nop *)
    end.

  Definition Step_steps_CaseList' a P V H :=
    match P with
    | nil => 0
    | t :: P' => 1 + CaseCom_steps + Step_steps_CaseCom a t P' V H
    end.

  Definition Step_steps_CaseList T V H :=
    match T with
    | nil => 0
    | (a,P) :: T' => 2 + CasePair_steps a + CaseList_steps P + Step_steps_CaseList' a P V H
    end.

  Definition Step_steps T V H :=
    1 + CaseList_steps T + Step_steps_CaseList T V H.

  Definition Step_T : tRel sigStep^+ 11 :=
    fun tin k =>
      exists (T V : list HClos) (H: Heap),
        tin[@Fin0] ≃ T /\
        tin[@Fin1] ≃ V /\
        tin[@Fin2] ≃ H /\
        (forall i : Fin.t 8, isVoid tin[@FinR 3 i]) /\
        Step_steps T V H <= k.

  Lemma Step_Terminates : projT1 Step ↓ Step_T.
  Proof.
    eapply TerminatesIn_monotone.
    { unfold Step. TM_Correct.
      - eapply RealiseIn_Realise. apply CaseCom_Sem.
      - eapply RealiseIn_TerminatesIn. apply CaseCom_Sem.
      - apply Step_lam_Terminates.
      - apply Step_app_Terminates.
      - apply Step_var_Terminates.
    }
    {
      intros tin k (T&V&H&HEncT&HEncV&HEncH&HInt&Hk). unfold Step_steps in Hk.
      exists (CaseList_steps T), (Step_steps_CaseList T V H). cbn; repeat split; try lia.
      { do 1 eexists; repeat split; simpl_surject; eauto. apply HInt. }
      specializeFin HInt. clear HInt.
      intros tmid bif (HCaseList&HCaseListInj); TMSimp. modpon HCaseList.
      destruct bif, T as [ | (a,P) T']; cbn; auto; modpon HCaseList.
      exists (CasePair_steps a), (1 + CaseList_steps P + Step_steps_CaseList' a P V H). cbn; repeat split; try lia.
      { hnf; cbn. exists (a, P); repeat split; simpl_surject; eauto. }
      intros tmid0 () (HCasePair&HCasePairInj); TMSimp. specialize (HCasePair (a,P)). modpon HCasePair. cbn in *.
      exists (CaseList_steps P), (Step_steps_CaseList' a P V H). cbn; repeat split; try lia.
      { hnf; cbn. exists P; repeat split; simpl_surject; eauto. }
      intros tmid1 bif (HCaseList'&HCaseListInj'); TMSimp. modpon HCaseList'.
      destruct bif, P as [ | t P']; auto; modpon HCaseList'. cbn.
      exists (CaseCom_steps), (Step_steps_CaseCom a t P' V H). cbn; repeat split; try lia.
      intros tmid2 ymid (HCaseCom&HCaseComInj); TMSimp. modpon HCaseCom.
      destruct ymid as [ t' | ]. destruct HCaseCom as [? <-]. destruct t'. all:cbn; auto; simpl_surject.
      - hnf; cbn. do 5 eexists; repeat split; TMSimp_goal; eauto. intros i; destruct_fin i; cbn; TMSimp_goal; auto.
      - hnf; cbn. do 5 eexists; repeat split; TMSimp_goal; eauto. intros i; destruct_fin i; cbn; TMSimp_goal; auto.
      - destruct HCaseCom as (?&->&?). hnf; cbn. do 6 eexists; repeat split; TMSimp_goal; eauto. simpl_surject. contains_ext.
    }
  Qed.

End StepMachine.


(** * Verified Translator
The G-code to R-code translator is written in Coq. As the translator accesses
the internal structures of both the G-machine and R-machine, we reuse these
structures and definitions to implement the translator. We also reuse the
parameterized heap defined in the [VHeap] modules to represent the heaps used in
the G-machine and R-machine. In the case of the G-machine the heap structure
contained nodes of types [tNode], whereas in the case of the R-machine, the
nodes are of type [tRMNodes].

*)
(* begin hide *)
Require Import List.
Require Import ZArith.
Require Import String.
Require Import Ascii.
Require Import Coq.ZArith.Znat.

Require Import VTypes.
Require Import VUtils.
Require Import VHeap.
Require Import GM.
Require Import RM.

Module Export XlatorImpl.
(* end hide *)
(** The code-table is defined as an associative container of labels to addresses
in the R-machine heap. In the present implementation we use an associative
container that employs a linear lookup technique yielding a running time
of %$O(n)$% for querying a key. This can be optimized by replacing the
internal implementation of the associative container [tAssocs] with a hash
table.

*)
Definition tCodeTable := tAssocs tName tAddr.
(** As presented in section %\S\ref{tx:txapproach}%, the [tCodeSegmentZone]
indicates the position where the translator inserts the generated code in the
code-segment of %$\rho$%.

*)
Inductive tCodeSegmentZone : Type :=
    | Prefix : tCodeSegmentZone
    | Suffix : tCodeSegmentZone.
(** * Translator State
The translator is modeled as an 8-tuple Coq record. Translating the stack-based
G-code instuctions to R-code involves register allocation. As defined in
section %\S\ref{rm:components}%, for each type of register in the R-machine,
the translator uses a simple register allocation strategy of incrementing
the last allocated index while allocating a new register. The fields [fVC],
[fPC] and [fRC] are used for bookkeeping the value of the last allocated
index for each register type.

[fCode] represents the code-segment, a list of R-code instructions,
and [fCodeTable] represents the code-table of an R-machine. The types
[tRMCode] [tRegs] and [tCodeTable] are defined in section
%\S\ref{rm:components}%. Once translation completes, these fields are
loaded into the R-machine configuration.

[fStack] is a list of R-code instructions manipulated as a stack. During the
translation process, the intermediate R-code generated as a result of
translating the [PushInt] G-code instruction is pushed onto the [fStack].
The [fRegStack] is an intermediate structure and is used during register
allocation. The last field [fGM] is the G-machine configuration being
translated. [put]* and [get]* functions, one for each field, define the
accessors and are omitted for brevity.

*)
Record tXlator : Type := mkXlator
    { fVC : nat;
      fPC : nat;
      fRC : nat;
      fCode : tRMCode;
      fStack : tRMCode;
      fRegStack : tRegs;
      fCodeTable : tCodeTable;
      fGM : tGMState }.
(* begin hide *)
Definition putVC (newVC : nat) (xlator : tXlator) : tXlator :=
    match xlator with
    | {| fVC := _;
         fPC := pC;
         fRC := rC;
         fCode := code;
         fStack := stack;
         fRegStack := rStack;
         fCodeTable := codeTable;
         fGM := gm |}
      =>
      {| fVC := newVC;
         fPC := pC;
         fRC := rC;
         fCode := code;
         fStack := stack;
         fRegStack := rStack;
         fCodeTable := codeTable;
         fGM := gm |}
    end.

Definition putPC (newPC : nat) (xlator : tXlator) : tXlator :=
    match xlator with
    | {| fVC := vC;
         fPC := _;
         fRC := rC;
         fCode := code;
         fStack := stack;
         fRegStack := rStack;
         fCodeTable := codeTable;
         fGM := gm |}
      =>
      {| fVC := vC;
         fPC := newPC;
         fRC := rC;
         fCode := code;
         fStack := stack;
         fRegStack := rStack;
         fCodeTable := codeTable;
         fGM := gm |}
    end.

Definition putRC (newRC : nat) (xlator : tXlator) : tXlator :=
    match xlator with
    | {| fVC := vC;
         fPC := pC;
         fRC := _;
         fCode := code;
         fStack := stack;
         fRegStack := rStack;
         fCodeTable := codeTable;
         fGM := gm |}
    =>
      {| fVC := vC;
         fPC := pC;
         fRC := newRC;
         fCode := code;
         fStack := stack;
         fRegStack := rStack;
         fCodeTable := codeTable;
         fGM := gm |}
    end.

Definition putCode (code : tRMCode) (xlator : tXlator) : tXlator :=
    match xlator with
    | {| fVC := vC;
         fPC := pC;
         fRC := rC;
         fCode := _;
         fStack := stack;
         fRegStack := rStack;
         fCodeTable := codeTable;
         fGM := gm |}
    =>
      {| fVC := vC;
         fPC := pC;
         fRC := rC;
         fCode := code;
         fStack := stack;
         fRegStack := rStack;
         fCodeTable := codeTable;
         fGM := gm |}
    end.

Definition putStack (stack : tRMCode) (xlator : tXlator) : tXlator :=
    match xlator with
    | {| fVC := vC;
         fPC := pC;
         fRC := rC;
         fCode := code;
         fStack := _;
         fRegStack := rStack;
         fCodeTable := codeTable;
         fGM := gm |}
    =>
      {| fVC := vC;
         fPC := pC;
         fRC := rC;
         fCode := code;
         fStack := stack;
         fRegStack := rStack;
         fCodeTable := codeTable;
         fGM := gm |}
    end.

Definition putRegStack (rStack : tRegs) (xlator : tXlator) : tXlator :=
    match xlator with
    | {| fVC := vC;
         fPC := pC;
         fRC := rC;
         fCode := code;
         fStack := stack;
         fRegStack := _;
         fCodeTable := codeTable;
         fGM := gm |}
    =>
      {| fVC := vC;
         fPC := pC;
         fRC := rC;
         fCode := code;
         fStack := stack;
         fRegStack := rStack;
         fCodeTable := codeTable;
         fGM := gm |}
    end.

Definition putCodeTable (codeTable : tCodeTable) (xlator : tXlator) : tXlator :=
    match xlator with
    | {| fVC := vC;
         fPC := pC;
         fRC := rC;
         fCode := code;
         fStack := stack;
         fRegStack := rStack;
         fCodeTable := _;
         fGM := gm |}
    =>
      {| fVC := vC;
         fPC := pC;
         fRC := rC;
         fCode := code;
         fStack := stack;
         fRegStack := rStack;
         fCodeTable := codeTable;
         fGM := gm |}
    end.

Definition putGM (gm : tGMState) (xlator : tXlator) : tXlator :=
    match xlator with
    | {| fVC := vC;
         fPC := pC;
         fRC := rC;
         fCode := code;
         fStack := stack;
         fRegStack := rStack;
         fCodeTable := codeTable;
         fGM := _ |}
    =>
      {| fVC := vC;
         fPC := pC;
         fRC := rC;
         fCode := code;
         fStack := stack;
         fRegStack := rStack;
         fCodeTable := codeTable;
         fGM := gm |}
    end.
(* end hide *)

(** * Translator Implementation
In this section we formalize the translation mechanism. We start by
defining the helper functions required by the translator.

The [addCode] helper function adds a list of R-code instructions to the
code-segment. The zone where the code is inserted is determined by the
[zone] parameter. The [addInstr] function prefixes a single instruction to
the code-segment. [pushRMInstr] and [popRMInstr] manipulate the stack and
implement the push and pop operations. The [pushReg] and [popReg] functions
manipulate the register stack.

*)

Definition addCode (code : tRMCode) (zone : tCodeSegmentZone) (xlator : tXlator) : tXlator :=
    match zone with
    | Prefix => putCode (app code xlator.(fCode)) xlator
    | Suffix => putCode (app xlator.(fCode) code) xlator
    end.

Definition addInstr (instr : tRMInstr) (xlator : tXlator) : tXlator :=
    putCode (instr :: xlator.(fCode)) xlator.

Definition pushRMInstr (instr : tRMInstr) (xlator : tXlator) : tXlator :=
    putStack (instr :: xlator.(fStack)) xlator.

Definition popRMInstr (xlator : tXlator) : option (tRMInstr * tXlator) :=
    match xlator.(fStack) with
    | instr :: instrs => Some (pair instr (putStack instrs xlator))
    | _ => None
    end.

Definition pushReg (reg : tReg) (xlator : tXlator) : tXlator :=
    putRegStack (reg :: xlator.(fRegStack)) xlator.

Definition popReg (xlator : tXlator) : option (tReg * tXlator) :=
    match xlator.(fRegStack) with
    | reg :: regs => Some (pair reg (putRegStack regs xlator))
    | _ => None
    end.

(** The [allocateReg] function allocates a register of a given type. It does so
by incrementing the count of the last allocated register of that type. When
a register of a particular type is required by the translator, it reads the
value from appropriate field.

*)

Definition allocateReg (regType : tRegType) (xlator : tXlator) : tXlator :=
    match regType with
    | V => putVC (S xlator.(fVC)) xlator
    | P => putPC (S xlator.(fPC)) xlator
    | R => putRC (S xlator.(fRC)) xlator
    end.

(** The [allocateRegAndLoadValue] helper function allocates a
register and loads a value into it. The load instruction is
recorded in the [fCodeStack], and the allocated register
is recorded in the [fRegStack].

The [allocateRegsAndLoadValues] helper function calls the
[allocateRegAndLoadValue] function recursively to load a
set of values.

*)

Definition allocateRegAndLoadValue
    (xlator : tXlator)
    (value : tRegVal)
    : tXlator :=
        let
            reg := Reg V xlator.(fVC)
        in
            let
                instr := (Const reg value)
            in
                allocateReg V (pushReg reg (pushRMInstr instr xlator)).

Fixpoint allocateRegsAndLoadValues
    (xlator : tXlator)
    (values : tRegVals)
    : tXlator :=
    match values with
    | nil         => xlator
    | v :: vs => allocateRegsAndLoadValues (allocateRegAndLoadValue xlator v) vs
    end.

(** The [addCodeEntry] function take a string label, indicating the name of a
supercombinator or a label indicating the address of an unconditional jump
and an address. It creates a pair of these two elements and adds this to the
code-table.

*)

Definition addCodeEntry
    (name : tName)
    (addr : tAddr)
    (xlator : tXlator) : tXlator :=
    putCodeTable ((pair name addr)::xlator.(fCodeTable)) xlator.

Open Local Scope nat_scope.

(** [getSCStream] takes as its input the name of a supercombinator and retrieves
the G-code instruction sequence associated with the body of the
supercombinator by looking up the address of the supercombinator in the
globals section of the G-machine and then using that address to fetch the
instruction stream G-machine heap. The return type is the option monad,
which contains the [NGlobal] node in case of a successful lookup. If the
lookup fails or if the node associated with the address is not a
supercombinator the [None] value is returned indicating an error condition.

The [getNumArgs] function takes a supercombinator name and returns the
number of arguments that the supercombinator accepts. This is useful for
parameter register allocation during translating function applications.

*)

Definition getSCStream (name : tName) (xlator : tXlator) : option GMi.tNode :=
    match assocLookup (GMi.getGlobals xlator.(fGM)) name stringComp with
    | Some addr =>
        match (hLookup (GMi.getHeap xlator.(fGM)) addr) with
        | Some node =>
            match node with
            | NGlobal numArgs innerCode => Some node
            | _ => None
            end
        | _ => None
        end
    | _ => None
    end.

Definition getNumArgs (name : tName) (xlator : tXlator) : nat :=
    match getSCStream name xlator with
    | Some (NGlobal numArgs innerCode) => numArgs
    | _ => 0
    end.

(** The [loadInstr] helper function compiles a list of instructions from
the intermediate instruction stack of the translator. It takes as an
argument the number of instructions to load. Once instructions are
loaded into the list, those entries are popped off the stack. The
[loadRegs] function is similar, except that it works on registers
instead of instructions. The [getCodeAddress] function returns the
address of the input label by looking up the code-table.

*)

Definition loadInstr (numArgs : nat) (xlator : tXlator) : (tRMCode * tXlator) :=
     let
         rmCode := take numArgs xlator.(fStack)
     in
         (pair rmCode (putStack (drop numArgs xlator.(fStack)) xlator)).

Definition loadRegs (numArgs : nat) (xlator : tXlator) : (tRegs * tXlator) :=
     let
         regs := take numArgs xlator.(fRegStack)
     in
         (pair regs (putRegStack (drop numArgs xlator.(fRegStack)) xlator)).

Definition getCodeAddress (name : tName) (xlator : tXlator) : tAddr :=
    match assocLookup xlator.(fCodeTable) name stringComp with
    | Some addr => addr
    | _ => NullAddr
    end.

Import ListNotations.

(** ** Translating Function Application
The [Invoke_static] instruction of Dalvik is used to generate a
function call in the R-machine. The number of arguments, [numArgs], required
by the supercombinator is looked up using the [getNumArgs] helper function.
[numArgs] registers are streamed from the register stack using the [loadRegs]
helper function into the [regs] variable. In a similar manner, the
instructions for populating the parameter registers required by the function
call are streamed from the translator's [fStack] field using the helper
function [loadInstr] into the [instrs] variable. Finally, the instructions
for the function call are assembled in the following order:
%
\begin{itemize}
\item instructions (\texttt{instrs}) required to populate the function call parameter
registers are laid out
\item the function call instruction with appropriate registers (\texttt{regs}) is laid
out
\item instruction required to move the result of the function call (using
the \texttt{Move\_result} instruction) is laid out
\end{itemize}
%
As [Move_result] requires a register to store the return value of the
function call, a new value register is allocated through the [allocateReg]
call, resulting in a modified translator state. The laid out instructions
along with the modified translator state are returned back to the caller
as a pair of type [(tRMCode * tXlator)].

*)

Definition generateCall
    (numArgs : nat)
    (name : tName)
    (xlator : tXlator)
    : (tRMCode * tXlator):=
    let
        (regs, xlator') := loadRegs numArgs xlator
    in
        let
            (instrs, xlator'') := (loadInstr numArgs xlator')
        in
            (pair
                (app instrs [Invoke_static regs name; Move_result (Reg V xlator.(fVC))])
                (allocateReg V xlator'')).
(** ** Translating Dyadic and Monadic Operations
The [generateDyadicCode] function is used to translate binary arithmetic and
logical G-code instructions in R-code. This generic function allocates a
register for holding the return value and used the [loadRegs] function to
retrieve the list of registers containing the operands. The R-code
instruction for the operator is laid out based on a match on the [op]
parameter followed by the second and the first parameter registers. The
instructions are then laid out at the prescribed [zone] in the translator's
code-segment. The [generateMonadicCode] function is similar, except that it
requires a single operand, and hence uses a single register.

*)
Definition generateDyadicCode
(op : tGMInstr)
(zone : tCodeSegmentZone)
(xlator : tXlator)
: tXlator :=
let
 vReg := Reg V xlator.(fVC)
 in
     let
     (regs, xlator') := loadRegs 2 (allocateReg V xlator)
     in
         let
         code := match op with
         | GMi.Add => [Add vReg (nth 1 regs (R, 0)) (nth 0 regs (R, 0))]
         | GMi.Sub => [Sub vReg (nth 1 regs (R, 0)) (nth 0 regs (R, 0))]
         | GMi.Mul => [Mul vReg (nth 1 regs (R, 0)) (nth 0 regs (R, 0))]
         | GMi.Div => [Div vReg (nth 1 regs (R, 0)) (nth 0 regs (R, 0))]
         | GMi.Eq => [CmpEq vReg (nth 1 regs (R, 0)) (nth 0 regs (R, 0))]
         | GMi.Ne => [CmpNe vReg (nth 1 regs (R, 0)) (nth 0 regs (R, 0))]
         | GMi.Lt => [CmpLt vReg (nth 1 regs (R, 0)) (nth 0 regs (R, 0))]
         | GMi.Le => [CmpLe vReg (nth 1 regs (R, 0)) (nth 0 regs (R, 0))]
         | GMi.Gt => [CmpGt vReg (nth 1 regs (R, 0)) (nth 0 regs (R, 0))]
         | GMi.Ge => [CmpGe vReg (nth 1 regs (R, 0)) (nth 0 regs (R, 0))]
         | _ => nil
         end
         in
             addCode code zone xlator'.

Definition generateMonadicCode
    (op : tGMInstr)
    (zone : tCodeSegmentZone)
    (xlator : tXlator)
    : tXlator :=
    let
        vReg := Reg V xlator.(fVC)
    in
        let
            (regs, xlator') := loadRegs 1 (allocateReg V xlator)
        in
            let
                code :=
                match op with
                | GMi.Neg=> (Neg vReg (nth 0 regs (R, 0)))::nil
                | _ => nil
                end
            in
                addCode code zone xlator'.
(** ** In-Built Functions
As the G-code program that is being translated is designed to run on the
G-machine, it contains several graph and stack manipulation related
instructions, such as [Unwind], [Update], [Slide] to mention a few.
On the other hand a register machine does not have graph or stack
manipulation instructions in its set. To bridge this gap, a library of
in-built functions is defined and loaded as a part of the initial
configuration of every R-machine instance. The translator on encountering
such G-code instructions generates an appropriate [Invoke-static] call to
the corresponding in-built function. This is implemented in the
[generateBuiltInCall] function defined below.

*)
Definition generateBuiltInCall
    (inbuilt : tName)
    (args : tRegVals)
    (zone : tCodeSegmentZone)
    (xlator : tXlator)
    : tXlator :=
    let
        xlator' := allocateRegsAndLoadValues xlator args
    in
        let
            (code, xlator'') := generateCall (List.length args) inbuilt xlator'
        in
            addCode code zone xlator''.
(*
| GMi.Alloc num => addCode [Invoke_static [reg0] "__allocNode"; Move_result reg1] zone xlator
| GMi.Unwind => addCode [Invoke_static [] "__unwind"] zone xlator
| GMi.Pop num => addCode [Invoke_static [] "__pop"] zone xlator
| GMi.Update num => addCode [Invoke_static [reg0] "__update"] zone xlator
| GMi.Slide num => addCode [Invoke_static [reg0] "__slide"] zone xlator
| GMi.MkAp => addCode [Invoke_static [] "__mkAp"] zone xlator
| GMi.Eval => addCode [Invoke_static [] "__eval"] zone xlator
| GMi.Pack tag arity => xlator
| GMi.Split num => addCode [Invoke_static [reg0] "__split"] zone xlator
| GMi.Print => addCode [Invoke_static [] "__print"] zone xlator
| GMi.Cond trueBranch falseBranch => addCode [Invoke_static [reg0; reg1] "__cond"] zone xlator
*)
(** ** Translator Dispatch Function
The recursive function [translateCode] performs the heavy lifting during a
translator run. It accepts a translator state, a G-code stream and the zone
where the translated R-code instruction is appended to in the code-segment.
The [{struct code}] directive tells Coq that [code] is the reducing argument
to this [Fixpoint] definition.

Each instruction from the code stream is examined, and dispatched for
translation based on the match. The [PushGlobal] instruction is translated
to a function call, the [PushInt] instruction results in a register
allocation, followed by pushing a [Const] instruction in [fStack] and the
allocated register in the [fRegStack] fields of the translator. The [Push]
instruction results in a parameter register allocation which is subsequently
pushed onto the register stack.

For all dyadic and monadic instructions, the appropriate helper function is
invoked to generate the required code. The [generateBuiltInCall] function
translates the G-machine graph and stack manipulation instructions to
reserved built-in functions. The function names are prefixed with
a double underscore to indicate that they are machine internal.

Translation proceeds till the [code] is exhausted, upon which the
modified translator object is returned to the caller.

*)
(* begin hide *)
Open Local Scope string_scope.
(* end hide *)
Fixpoint translateCode
    (xlator : tXlator)
    (code : tGMCode)
    (zone : tCodeSegmentZone)
    {struct code} : tXlator :=
    match code with
    | nil => xlator
    | instr :: code' =>
        let xlator''' :=
            match instr with
            | GMi.PushGlobal name =>
                let (code, xlator'') :=
                    generateCall (getNumArgs name xlator) name xlator
                in addCode code zone xlator''
            | GMi.PushInt num => allocateRegAndLoadValue xlator num
            | GMi.Push num =>
                let pReg := Reg P xlator.(fPC)
                in allocateReg P (pushReg pReg xlator)
            | GMi.Add        => generateDyadicCode GMi.Add zone xlator
            | GMi.Sub        => generateDyadicCode GMi.Sub zone xlator
            | GMi.Mul        => generateDyadicCode GMi.Mul zone xlator
            | GMi.Div        => generateDyadicCode GMi.Div zone xlator
            | GMi.Eq         => generateDyadicCode GMi.Eq zone xlator
            | GMi.Ne         => generateDyadicCode GMi.Ne zone xlator
            | GMi.Lt         => generateDyadicCode GMi.Lt zone xlator
            | GMi.Le         => generateDyadicCode GMi.Le zone xlator
            | GMi.Gt         => generateDyadicCode GMi.Gt zone xlator
            | GMi.Ge         => generateDyadicCode GMi.Ge zone xlator
            | GMi.Neg        => generateMonadicCode GMi.Neg zone xlator
            | GMi.Alloc num  =>
                generateBuiltInCall "__alloc" [Z.of_nat num] zone xlator
            | GMi.Unwind     => generateBuiltInCall "__unwind" [] zone xlator
            | GMi.Pop num    => generateBuiltInCall "__pop" [] zone xlator
            | GMi.Update num =>
                generateBuiltInCall "__update" [Z.of_nat num] zone xlator
            | GMi.Slide num  =>
                generateBuiltInCall "__slide" [Z.of_nat num] zone xlator
            | GMi.MkAp       => generateBuiltInCall "__mkAp" [] zone xlator
            | GMi.Eval       => generateBuiltInCall "__eval" [] zone xlator
            | GMi.Split num  =>
                generateBuiltInCall "__split" [Z.of_nat num] zone xlator
            | GMi.Print      => generateBuiltInCall "__print" [] zone xlator
            | _              => xlator
(*
            | GMi.Cond tb fb       => generateBranchCalls tb fb zone xlator
            | GMi.Pack tag arity   => xlator
*)
            end
        in translateCode xlator''' code' zone
    end.

Close Local Scope nat_scope.

(** ** Translation Kernel
The translator retrieves the supercombinator definitions from the G-machine's
global and heap sections and translates them into R-code using the
[translateAssocs] function. Finally, the [main] function is
translated to RM code.
*)

Definition translateGlobal
    (xlator : tXlator)
    (code : tGMCode) : tXlator :=
    translateCode xlator code Suffix.

Definition translateAssoc
    (xlator : tXlator)
    (name : tName)
    (value : tNode) : tXlator :=
    let
        codeAddr := S (S (S (List.length xlator.(fCode))))
    in
        match value with
        | NGlobal n code =>
            addCodeEntry
                name
                codeAddr
                (translateGlobal xlator code)
        | _ => xlator
        end.

Import ListNotations.

Definition getEndMarker : string :=
    "end".

Fixpoint translateAssocs
    (globals : tGMGlobals)
    (xlator : tXlator) : tXlator :=
    match globals with
    | assoc :: assocs =>
        let
            (name, addr) := assoc
        in
            let
                node := snd(nth (addr - 1) (getHeapAssocs (GMi.getHeap xlator.(fGM))) (pair NullAddr (NGlobal 0 [])))
            in
                translateAssocs assocs (translateAssoc xlator name node)
    | _ => xlator
    end.

Definition translate (xlator : tXlator) : tXlator :=
    let
        xlator' := translateAssocs (GMi.getGlobals xlator.(fGM)) xlator
    in
        let
            xlator'' := addCode [Goto "end"] Prefix xlator'
        in
            let
                xlator''' := translateCode xlator'' (GMi.getCode xlator''.(fGM)) Prefix
            in
                addCode [Halt] Suffix (addCodeEntry getEndMarker (List.length xlator'''.(fCode)) xlator''').

Close Local Scope string_scope.

End XlatorImpl.


From Coq Require Import String NArith.

From Vyper Require Import Config FSet.

From Vyper.L30 Require Import AST.

Section Callset.

Context {C: VyperConfig}.

(** Get the set of functions called by an expression. *)
Definition small_stmt_callset (ss: small_stmt)
: string_set
:= let _ := string_set_impl in
   match ss with
   | PrivateCall _ name _ _ => singleton name
   | _ => empty
   end.

Fixpoint stmt_callset (s: stmt)
:= let _ := string_set_impl in
   match s with
   | SmallStmt a => small_stmt_callset a
   | IfElseStmt cond yes no => (union (stmt_callset yes) (stmt_callset no))
   | Loop _ _ body => stmt_callset body
   | Semicolon a b => union (stmt_callset a) (stmt_callset b)
   end.

Definition decl_callset (d: decl)
:= let _ := string_set_impl in match d with
   | StorageVarDecl _ => empty
   | FunDecl name args body => stmt_callset body
   end.

Ltac descend H
:= subst; cbn in H;
   repeat try rewrite union_subset_and in H;
   repeat rewrite Bool.andb_true_iff in H;
   try tauto.

Lemma callset_descend_small_stmt {s: stmt} {ss: small_stmt}
                                 {allowed_calls: string_set}
                                 (E: s = SmallStmt ss)
                                 (ok: let _ := string_set_impl in
                                      FSet.is_subset (stmt_callset s) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (small_stmt_callset ss) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_stmt_if_then {cond: N} {yes no s: stmt}
                                   {allowed_calls: string_set}
                                   (E: s = IfElseStmt cond yes no)
                                   (ok: let _ := string_set_impl in
                                        FSet.is_subset (stmt_callset s) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (stmt_callset yes) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_stmt_if_else {cond: N} {yes no s: stmt}
                                   {allowed_calls: string_set}
                                   (E: s = IfElseStmt cond yes no)
                                   (ok: let _ := string_set_impl in
                                        FSet.is_subset (stmt_callset s) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (stmt_callset no) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_loop_body {s: stmt} {body: stmt} {var count}
                                {allowed_calls: string_set}
                                (E: s = Loop var count body)
                                (ok: let _ := string_set_impl in
                                     FSet.is_subset (stmt_callset s) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (stmt_callset body) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_semicolon_left {a b s: stmt}
                                     {allowed_calls: string_set}
                                     (E: s = Semicolon a b)
                                     (ok: let _ := string_set_impl in
                                          FSet.is_subset (stmt_callset s) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (stmt_callset a) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_semicolon_right {a b s: stmt}
                                      {allowed_calls: string_set}
                                      (E: s = Semicolon a b)
                                      (ok: let _ := string_set_impl in
                                           FSet.is_subset (stmt_callset s) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (stmt_callset b) allowed_calls = true.
Proof.
descend ok.
Qed.

End Callset.