(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*                       mCertiKOS C Source Code                       *)
(*                                                                     *)
(*                        Xiongnan (Newman) Wu                         *)
(*                                                                     *)
(*                          Yale University                            *)
(*                                                                     *)
(* *********************************************************************)
Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Cop.
Require Import Clight.
Require Import CDataTypes.
Require Import Ctypes.

(**
<<
  extern int get_size(void);
  extern int get_mms(unsigned int);
  extern int get_mml(unsigned int);
  extern int is_usable(unsigned int);
  extern void set_norm(unsigned int, unsigned int);
  extern void set_nps(unsigned int);
  extern void container_init(unsigned int);

  void mem_init(unsigned int mbi_adr)
  {
    unsigned int i, j, s, l, isnorm, nps, maxs, size, mm, flag;
    boot_loader(mbi_adr);
    i = 0;
    size = get_size();
    nps = 0;
    while(i < size)
    {
        s = get_mms(i);
        l = get_mml(i);
        maxs = (s + l) / PgSize + 1;
        if(maxs > nps)
            nps = maxs;
        i++;
    }
    set_nps(nps);
    i = 0;
    while(i < nps)
    {
        if(i < kern_low || i >= kern_high)
            set_norm(i, 1);
        else
        {
            j = 0;
            flag = 0;
            isnorm = 0;
            while(j < size && flag == 0)
            {
                s = get_mms(j);
                l = get_mml(j);
                isnorm = is_usable(j);
                if(s <= i * PgSize && l + s >= (i + 1) * PgSize)
                    flag = 1;
                j++;
            }
            if(flag == 1 && isnorm == 1)
                set_norm(i, 2);
            else
                set_norm(i, 0);
        }
        i++;
    }
  }
>>
 *)

(** Local temporaries used *)
Local Open Scope positive_scope.
Let ti: ident := 1.
Let tj: ident := 2.
Let ts: ident := 3.
Let tl: ident := 4.
Let tisnorm: ident := 5.
Let tnps: ident := 6.
Let tmaxs: ident := 7.
Let tsize: ident := 8.
Let tmm: ident := 9.
Let tflag: ident := 10.
Let tmbi_adr: ident := 11.

Definition nps_while_condition : expr :=
  (Ebinop Olt (Etempvar ti tint) (Etempvar tsize tint) tint).

Definition nps_while_body : statement :=
  (Ssequence
     (Scall (Some ts) (Evar get_mms (Tfunction (Tcons tint Tnil) tint cc_default))
            ((Etempvar ti tint) :: nil))
     (Ssequence
        (Scall (Some tl) (Evar get_mml (Tfunction (Tcons tint Tnil) tint cc_default))
               ((Etempvar ti tint) :: nil))
        (Ssequence
           (Sset tmaxs (Ebinop Oadd
                               (Ebinop Odiv
                                       (Ebinop Oadd (Etempvar ts tint) (Etempvar tl tint) tint)
                                       (Econst_int (Int.repr PgSize) tint) tint)
                               (Econst_int (Int.repr 1) tint) tint))
           (Ssequence
              (Sifthenelse
                 (Ebinop Ogt (Etempvar tmaxs tint) (Etempvar tnps tint) tint)
                 (Sset tnps (Etempvar tmaxs tint))
                 Sskip
              )
              (Sset ti (Ebinop Oadd (Etempvar ti tint)
                               (Econst_int (Int.repr 1) tint) tint))))))
.

Definition inner_while_condition : expr :=
  (Ebinop Oand
          (Ebinop Olt (Etempvar tj tint) (Etempvar tsize tint) tint)
          (Ebinop Oeq (Etempvar tflag tint) (Econst_int (Int.repr 0) tint) tint) tint).

Definition inner_while_body : statement :=
  (Ssequence
     (Scall (Some ts) (Evar get_mms (Tfunction (Tcons tint Tnil) tint cc_default))
            ((Etempvar tj tint) :: nil))
     (Ssequence
        (Scall (Some tl) (Evar get_mml (Tfunction (Tcons tint Tnil) tint cc_default))
               ((Etempvar tj tint) :: nil))
        (Ssequence
           (Scall (Some tisnorm) (Evar is_usable (Tfunction (Tcons tint Tnil) tint cc_default))
                  ((Etempvar tj tint) :: nil))
           (Ssequence
              (Sifthenelse
                 (Ebinop Ole (Etempvar ts tint)
                         (Ebinop Omul (Etempvar ti tint) (Econst_int (Int.repr PgSize) tint) tint) tint)
                 (Sifthenelse
                    (Ebinop Oge (Ebinop Oadd (Etempvar tl tint) (Etempvar ts tint) tint)
                            (Ebinop Omul (Ebinop Oadd (Etempvar ti tint) (Econst_int (Int.repr 1) tint) tint)
                                    (Econst_int (Int.repr PgSize) tint) tint) tint)
                    (Sset tflag (Econst_int (Int.repr 1) tint))
                    Sskip
                 )
                 Sskip
              )
              (Sset tj (Ebinop Oadd (Etempvar tj tint) (Econst_int (Int.repr 1) tint) tint))))))
.

Definition outter_while_condition : expr :=
  (Ebinop Olt (Etempvar ti tint) (Etempvar tnps tint) tint).

Definition outter_while_body : statement :=
  (Ssequence
     (Sifthenelse
        (Ebinop Olt (Etempvar ti tint) (Econst_int (Int.repr kern_low) tint) tint)
        (Scall None (Evar set_norm (Tfunction (Tcons tint (Tcons tint Tnil)) Tvoid cc_default))
               ((Etempvar ti tint) :: (Econst_int (Int.repr 1) tint) :: nil))
        (Sifthenelse
           (Ebinop Oge (Etempvar ti tint) (Econst_int (Int.repr kern_high) tint) tint)
           (Scall None (Evar set_norm (Tfunction (Tcons tint (Tcons tint Tnil)) Tvoid cc_default))
                  ((Etempvar ti tint) :: (Econst_int (Int.repr 1) tint) :: nil))
           (Ssequence
              (Sset tj (Econst_int (Int.repr 0) tint))
              (Ssequence
                 (Sset tflag (Econst_int (Int.repr 0) tint))
                 (Ssequence
                    (Sset tisnorm (Econst_int (Int.repr 0) tint))
                    (Ssequence
                       (Swhile inner_while_condition inner_while_body)
                       (Sifthenelse
                          (Ebinop Oeq (Etempvar tflag tint) (Econst_int (Int.repr 1) tint) tint)
                          (Sifthenelse
                             (Ebinop Oeq (Etempvar tisnorm tint) (Econst_int (Int.repr 1) tint) tint)
                             (Scall None (Evar set_norm (Tfunction (Tcons tint (Tcons tint Tnil)) Tvoid cc_default))
                                    ((Etempvar ti tint) :: (Econst_int (Int.repr 2) tint) :: nil))
                             (Scall None (Evar set_norm (Tfunction (Tcons tint (Tcons tint Tnil)) Tvoid cc_default))
                                    ((Etempvar ti tint) :: (Econst_int (Int.repr 0) tint) :: nil))
                          )
                          (Scall None (Evar set_norm (Tfunction (Tcons tint (Tcons tint Tnil)) Tvoid cc_default))
                                 ((Etempvar ti tint) :: (Econst_int (Int.repr 0) tint) :: nil))
                       )
           ))))
        )
     )
     (Sset ti (Ebinop Oadd (Etempvar ti tint)
                      (Econst_int (Int.repr 1) tint) tint))
  )
.

Definition mem_init_body : statement :=
  (Ssequence
     (Scall None (Evar boot_loader (Tfunction (Tcons tint Tnil) Tvoid cc_default)) ((Etempvar tmbi_adr tint)::nil))
     (Ssequence
        (Sset ti (Econst_int (Int.repr 0) tint))
        (Ssequence
           (Scall (Some tsize) (Evar get_size (Tfunction Tnil tint cc_default)) nil)
           (Ssequence
              (Sset tnps (Econst_int (Int.repr 0) tint))
              (Ssequence
                 (Swhile nps_while_condition nps_while_body)
                 (Ssequence
                    (Scall None (Evar set_nps (Tfunction (Tcons tint Tnil) Tvoid cc_default)) ((Etempvar tnps tint) :: nil))
                    (Ssequence
                       (Sset ti (Econst_int (Int.repr 0) tint))
                       (Swhile outter_while_condition outter_while_body)
  )))))))
.

Definition f_mem_init := {|
                          fn_return := Tvoid;
                          fn_callconv := cc_default;
                          fn_params := ((tmbi_adr, tint)::nil);
                          fn_vars := nil;
                          fn_temps := ((ti, tint) :: (tj, tint) :: (ts, tint) :: (tl, tint) :: (tisnorm, tint) :: (tnps, tint) :: (tmaxs, tint) :: (tsize, tint) :: (tmm, tint) :: (tflag, tint) :: nil);
                          fn_body := mem_init_body
                        |}.


Set Universe Polymorphism.

Definition T@{i} := Type@{i}.
Fail Definition U@{i} := (T@{i} <: Type@{i}).
Fail Definition eqU@{i j} : @eq T@{j} U@{i} T@{i} := eq_refl.


Require Import VST.msl.msl_standard.
Require Import VST.msl.Coqlib2.
Require Import VST.veric.shares.

Section UNPROVABLE.

Variable wishes_eq_horses : False.

Lemma unrel_glb:
 forall a b,
    Share.unrel a b = Share.unrel a (Share.glb a b).
contradiction wishes_eq_horses.
Qed.

Lemma share_rel_unrel':
  forall r sh,
    Share.rel r (Share.unrel r sh) = Share.glb r sh.
Proof.
contradiction wishes_eq_horses.
Qed.

Lemma share_sub_Lsh:
forall sh, identity (Share.unrel Share.Rsh sh) -> join_sub sh Share.Lsh.
Proof.
 intros.
 rewrite (Share.decompose_Rsh sh) in H.
 remember (decompose sh).
 symmetry in Heqp. destruct p as [sh1 sh2].
 simpl in H.
 apply identity_share_bot in H. subst.
 generalize (top_correct' sh1);intro.
 destruct H.
 exists (Share.recompose (x, Share.bot)).
 rewrite Share.Lsh_recompose.
 assert (sh = Share.recompose (sh1, Share.bot)).
  rewrite <- Heqp. rewrite Share.recompose_decompose. trivial.
 rewrite H0.
 eapply Share.decompose_join.
 rewrite Share.decompose_recompose. f_equal.
 rewrite Share.decompose_recompose. f_equal.
 rewrite Share.decompose_recompose. f_equal.
 split. trivial.
 split. apply Share.glb_bot. apply Share.lub_bot.
Qed.

Lemma join_splice2_aux:
forall a1 a2 a3 b1 b2 b3,
Share.lub (Share.rel Share.Lsh (Share.lub a1 a2)) (Share.rel Share.Rsh (Share.lub b1 b2))
= Share.lub (Share.rel Share.Lsh a3) (Share.rel Share.Rsh b3) ->
Share.lub a1 a2 = a3 /\ Share.lub b1 b2 = b3.
Proof with try tauto.
 intros. rewrite Share.lub_rel_recompose in H.
 generalize (Share.decompose_recompose (Share.lub a1 a2, Share.lub b1 b2));intro.
 rewrite H in H0.
 rewrite Share.lub_rel_recompose in H0.
 rewrite Share.decompose_recompose in H0.
 split;congruence.
Qed.

Lemma share_rel_unrel:
  forall r sh,
    join_sub sh r ->
    Share.rel r (Share.unrel r sh) = sh.
Proof.
intros.
rewrite share_rel_unrel'.
destruct H as [a [H H0]].
subst r.
rewrite Share.glb_commute.
rewrite Share.distrib1.
rewrite H.
rewrite Share.lub_bot.
apply Share.glb_idem.
Qed.

Lemma glb_rel_Lsh_Rsh:
 forall a b, Share.glb (Share.rel Share.Lsh a) (Share.rel Share.Rsh b) = Share.bot.
Proof.
intros.
assert (H := rel_leq Share.Lsh a).
assert (H0 := rel_leq Share.Rsh b).
apply leq_join_sub in H.
apply leq_join_sub in H0.
forget (Share.rel Share.Lsh a) as aL.
forget (Share.rel Share.Rsh b) as bR.
apply Share.ord_antisym; [ | apply Share.bot_correct].
rewrite <- glb_Lsh_Rsh.
forget Share.Lsh as L.
forget Share.Rsh as R.
apply glb_less_both; auto.
Qed.

Lemma glb_Rsh_rel_Lsh_sh:
 forall sh,
  Share.glb Share.Rsh (Share.rel Share.Lsh sh) = Share.bot.
Proof.
intros.
destruct (Share.split Share.top) eqn:?.
unfold Share.Rsh, Share.Lsh. rewrite Heqp; simpl.
rewrite Share.glb_commute.
destruct (rel_join t t t0 _ (split_join _ _ _ Heqp)).
clear - H Heqp.
pose proof (rel_leq t t0).
rewrite <- leq_join_sub in H0.
rewrite Share.ord_spec1 in H0.
rewrite H0 in H.
rewrite <- Share.glb_assoc in H.
rewrite <- Share.rel_preserves_glb in H.
pose proof (rel_leq t (Share.glb t t0)).
apply leq_join_sub in H1.
apply Share.ord_spec1 in H1. rewrite <- H1 in H.
clear H1.
pose proof bot_identity. rewrite <- H in H1.
apply (rel_nontrivial) in H1.
destruct H1.
apply split_nontrivial' in Heqp; auto.
apply identity_share_bot in Heqp.
apply Share.nontrivial in Heqp; contradiction.
clear H.
apply identity_share_bot in H1.
clear - H1.
pose proof (rel_leq t sh).
forget (Share.rel t sh) as b.
destruct H as [a [? ?]].
subst t.
rewrite Share.glb_commute in H1; rewrite Share.distrib1 in H1.
rewrite Share.glb_commute in H1.
pose proof (Share.lub_upper1 (Share.glb b t0) (Share.glb t0 a)).
rewrite H1 in H0.
apply Share.ord_antisym; auto.
apply Share.bot_correct.
Qed.

Lemma right_nonempty_readable:
  forall rsh sh, sepalg.nonidentity sh <->
     readable_share (Share.splice rsh sh).
Proof.
intros.
unfold readable_share, Share.splice.
unfold nonempty_share,nonidentity.
assert (identity sh <-> identity (Share.glb Share.Rsh (Share.lub (Share.rel Share.Lsh rsh) (Share.rel Share.Rsh sh))));
  [ | intuition].
split; intro.
*
apply identity_share_bot in H. subst.
rewrite Share.rel_bot1.
rewrite Share.lub_bot.
rewrite glb_Rsh_rel_Lsh_sh.
apply bot_identity.
*
rewrite Share.distrib1 in H.
rewrite glb_Rsh_rel_Lsh_sh in H.
rewrite Share.lub_commute, Share.lub_bot in H.
assert (identity (Share.glb (Share.rel Share.Rsh Share.top) (Share.rel Share.Rsh sh)))
  by (rewrite Share.rel_top1; auto).
clear H.
rewrite <- Share.rel_preserves_glb in H0.
rewrite Share.glb_commute, Share.glb_top in H0.
apply rel_nontrivial in H0.
destruct H0; auto.
unfold Share.Rsh in H.
destruct (Share.split Share.top) eqn:?; simpl in *.
apply split_nontrivial' in Heqp; auto.
apply top_share_nonidentity in Heqp.
contradiction.
Qed.

Lemma writable_share_right: forall sh, writable_share sh -> Share.unrel Share.Rsh sh = Share.top.
Proof.
 intros.
 apply Share.contains_Rsh_e.
 apply H.
Qed.

Lemma unrel_bot:
 forall sh, nonidentity sh -> Share.unrel sh Share.bot = Share.bot.
Proof.
intros.
rewrite <- (Share.rel_bot1 sh) at 1.
rewrite Share.unrel_rel; auto.
Qed.

Lemma join_splice2_aux1:
  forall a1 a2 b1 b2,
  Share.lub (Share.rel Share.Lsh (Share.glb a1 a2)) (Share.rel Share.Rsh (Share.glb b1 b2)) = Share.bot ->
  Share.glb a1 a2 = Share.bot /\ Share.glb b1 b2 = Share.bot.
Proof. intros.
  rewrite !Share.rel_preserves_glb in H.
  apply lub_bot_e in H; destruct H.
  rewrite <- Share.rel_preserves_glb in H, H0.
  pose proof (rel_nontrivial Share.Lsh (Share.glb a1 a2)).
  rewrite H in H1. specialize (H1 bot_identity). clear H.
  pose proof (rel_nontrivial Share.Rsh (Share.glb b1 b2)).
  rewrite H0 in H. specialize (H bot_identity). clear H0.
  destruct H1. contradiction (Lsh_nonidentity H0).
  destruct H. contradiction (Rsh_nonidentity H).
  apply identity_share_bot in H.
  apply identity_share_bot in H0.
  auto.
Qed.

Lemma join_splice:
  forall a1 a2 a3 b1 b2 b3,
 sepalg.join a1 a2 a3 ->
 sepalg.join b1 b2 b3 ->
 sepalg.join (Share.splice a1 b1)  (Share.splice a2 b2)  (Share.splice a3 b3).
Proof.
intros.
unfold Share.splice.
destruct H, H0.
split.
*
rewrite Share.distrib1.
do 2 rewrite (Share.glb_commute (Share.lub _ _)).
rewrite Share.distrib1.
rewrite Share.distrib1.
rewrite !(Share.glb_commute (Share.rel _ a2)).
rewrite !(Share.glb_commute (Share.rel _ b2)).
rewrite <- !Share.rel_preserves_glb.
rewrite H,H0.
rewrite !Share.rel_bot1.
rewrite (Share.lub_commute Share.bot).
rewrite !Share.lub_bot.
rewrite Share.glb_commute.
rewrite !glb_rel_Lsh_Rsh.
apply Share.lub_bot.
*
subst a3 b3.
rewrite !Share.rel_preserves_lub.
forget (Share.rel Share.Lsh a1) as La1.
forget (Share.rel Share.Rsh b1) as Rb1.
forget (Share.rel Share.Lsh a2) as La2.
forget (Share.rel Share.Rsh b2) as Rb2.
rewrite !Share.lub_assoc.
f_equal.
rewrite Share.lub_commute.
rewrite !Share.lub_assoc.
f_equal.
apply Share.lub_commute.
Qed.

Lemma splice_bot2:
 forall sh, Share.splice sh Share.bot = Share.rel Share.Lsh sh.
Proof.
intros.
unfold Share.splice.
rewrite Share.rel_bot1.
rewrite Share.lub_bot.
auto.
Qed.

Lemma splice_unrel_unrel:
  forall sh,
   Share.splice (Share.unrel Share.Lsh sh) (Share.unrel Share.Rsh sh) = sh.
Proof.
intros.
unfold Share.splice.
rewrite !share_rel_unrel'.
rewrite share_distrib2'.
rewrite Share.lub_idem.
rewrite lub_Lsh_Rsh.
rewrite (Share.glb_commute Share.top).
rewrite Share.glb_top.
rewrite <- Share.glb_assoc.
rewrite (Share.lub_commute sh).
rewrite share_distrib1'.
rewrite (Share.glb_commute Share.Rsh).
rewrite glb_Lsh_Rsh.
rewrite (Share.lub_commute Share.bot), Share.lub_bot.
rewrite Share.glb_idem.
rewrite (Share.glb_commute sh).
rewrite <- Share.lub_assoc.
rewrite Share.glb_commute.
rewrite Share.lub_commute.
rewrite Share.glb_absorb.
auto.
Qed.

Lemma join_splice2:
  forall a1 a2 a3 b1 b2 b3 : Share.t,
  join (Share.splice a1 b1) (Share.splice a2 b2) (Share.splice a3 b3) ->
  join a1 a2 a3 /\ join b1 b2 b3.
Proof.
intros.
unfold Share.splice in H.
destruct H.
unfold join, Share.Join_ba.
assert ((Share.glb a1 a2 = Share.bot /\ Share.glb b1 b2 = Share.bot)
         /\ (Share.lub a1 a2 = a3 /\ Share.lub b1 b2 = b3)); [ | intuition].
split.
*
clear - H.
rewrite share_distrib1' in H.
rewrite (Share.lub_commute (Share.glb _ _)) in H.
rewrite Share.lub_assoc in H.
rewrite <- (Share.lub_assoc (Share.glb (Share.rel Share.Lsh _) _)) in H.
rewrite (Share.lub_commute (Share.lub _ _)) in H.
rewrite <- Share.lub_assoc in H.
rewrite <- !Share.rel_preserves_glb in H.
rewrite (Share.glb_commute (Share.rel Share.Rsh _)) in H.
rewrite !glb_rel_Lsh_Rsh in H.
rewrite (Share.lub_commute Share.bot), !Share.lub_bot in H.
rewrite Share.lub_commute in H.
apply join_splice2_aux1; auto.
*
clear - H0.
rewrite Share.lub_assoc in H0.
rewrite (Share.lub_commute (Share.rel Share.Rsh _)) in H0.
rewrite <- !Share.lub_assoc in H0.
rewrite <- Share.rel_preserves_lub in H0.
rewrite Share.lub_assoc in H0.
rewrite <- Share.rel_preserves_lub in H0.
rewrite (Share.lub_commute b2) in H0.
apply join_splice2_aux; auto.
Qed.

Lemma nonidentity_rel_Lsh: forall t, nonidentity (Share.rel Share.Lsh t) -> nonidentity t.
Proof.
  intros.
  rewrite <- splice_bot2 in H.
  intro.
  apply H; clear H.
  intros ? ? ?.
  rewrite <- (splice_unrel_unrel a), <- (splice_unrel_unrel b) in H |- *.
  forget (Share.unrel Share.Lsh a) as sh0.
  forget (Share.unrel Share.Rsh a) as sh1.
  forget (Share.unrel Share.Lsh b) as sh2.
  forget (Share.unrel Share.Rsh b) as sh3.
  apply join_splice2 in H.
  destruct H.
  apply H0 in H.
  apply bot_identity in H1.
  subst.
  auto.
Qed.

Lemma readable_share_unrel_Rsh: forall sh, readable_share sh <-> nonunit (Share.unrel Share.Rsh sh).
unfold readable_share in *.
Proof.
intros.
unfold nonempty_share.
transitivity (nonidentity (Share.unrel Share.Rsh sh)).
unfold nonidentity.
split; intro; contradict H.
apply identity_share_bot in H.
rewrite <- share_rel_unrel'.
rewrite H.
rewrite Share.rel_bot1.
apply bot_identity.
rewrite <- share_rel_unrel' in H.
apply rel_nontrivial in H.
destruct H; auto.
exfalso.
apply identity_share_bot in H.
unfold Share.Rsh in H.
destruct (Share.split Share.top) eqn:?. simpl in H. subst.
apply split_nontrivial' in Heqp.
apply identity_share_bot in Heqp.
apply Share.nontrivial; auto.
right.
apply bot_identity.
split.
apply nonidentity_nonunit.
intro.
hnf in H|-*; intro.
apply identity_share_bot in H0.
rewrite H0 in H.
apply (H Share.top).
red.
apply bot_join_eq.
Qed.

End UNPROVABLE.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  Useful lemmas about get functions.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.

Require Import FormalSyntax.
Require Import StaticSemanticsKindingAndContextWellFormedness.
Require Import VarLemmas.
Require Import ListLemmas.
Require Import ContextExtensionRelation.

Lemma getU_Some_Weakening:
  forall (u : Upsilon) (x : EVar) (p : P) (tau : Tau),
    getU u x p tau ->
    forall (u' : Upsilon),
      getU (u ++ u') x p tau.
Proof.
  intros u x p tau getUder.
  induction u.
  Case "[]".
   inversion getUder.
  Case "a :: u".
   intros u'.
   destruct a.
   destruct p0.
   inversion getUder.
   constructor.
   constructor.
   assumption.
   crush.
Qed.

(* TODO must be strengthened with WFDG and even WFDG d? *)
Lemma getG_weakening:
 forall (g : Gamma) (x : EVar) (tau : Tau),
   getG g x = Some tau ->
   (* WFDG [] g ->  *)
   forall (g' : Gamma),
     (* WFDG [] (g ++ g') -> *)
    getG (g ++ g') x = Some tau.
Proof.
Admitted.

Lemma getH_Some_weakening:
  forall (h : H) (x : EVar) (v : E),
    getH h x = Some v ->
    forall (h' : H),
      getH (h ++ h') x = Some v.
Proof.
  intros h x v getHder.
  functional induction (getH h x); crush.
Qed.

Lemma getD_None_Strengthening:
  forall (d d' : Delta) (alpha : TVar),
    getD (d ++ d') alpha = None ->
    getD d alpha = None.
Proof.
 intros.
 induction d.
 Case "d = []".
  simpl.
  destruct alpha.
  reflexivity.
 Case "a :: d".
  destruct a.
  unfold getD.
  fold getD.
  unfold getD in H.
  simpl in H.
  fold getD in H.
  destruct (beq_tvar alpha t).
  inversion H.
  apply IHd in H.
  assumption.
Qed.

Lemma getG_None_Strengthening:
  forall (g g' : Gamma) (x : EVar),
    getG (g ++ g') x = None ->
    getG g x = None.
Proof.
 intros.
 induction g.
 Case "g = []".
  simpl.
  destruct x.
  reflexivity.
 Case "a :: g".
  destruct a.
  unfold getG.
  fold getG.
  rewrite cons_is_append_singleton in H.
  rewrite <- app_assoc in H.
  case_eq (beq_evar x e).
  intros.
  inversion H.
  rewrite H0 in H2.
  inversion H2.
  intros.
  unfold getG in H.
  simpl in H.
  fold getG in H.
  rewrite H0 in H.
  apply IHg in H.
  assumption.
Qed.

Lemma getD_Some_Weakening:
 forall (alpha : TVar) (k : Kappa) (d d' : Delta),
   WFD (d ++ d') ->
   getD d alpha = Some k ->
   getD (d ++ d') alpha = Some k.
Proof.
  intros alpha k d d' WFDder getDder.
  functional induction (getD d alpha); crush.
  inversion WFDder.
  apply IHo in H3.
  assumption.
  assumption.
Qed.

Lemma getG_Some_Weakening:
 forall (x: EVar) (tau : Tau) (g g' : Gamma),
   getG g x = Some tau ->
   getG (g ++ g') x = Some tau.
Proof.
  intros x tau g g' getGder.
  functional induction (getG g x); crush.
Qed.

Lemma getD_Some_non_empty_d:
  forall (d : Delta) (alpha : TVar) (k : Kappa),
    getD d alpha = Some k ->
    d <> [].
Proof.
  intros d alpha k getDder.
  crush.
Qed.

Lemma getD_extension_agreement:
  forall (d : Delta) (alpha : TVar) (k : Kappa),
    getD d  alpha = Some k ->
    WFD d ->
    forall (d' : Delta),
      WFD d' ->
      ExtendedByD d d' ->
      getD d' alpha = Some k.
Proof.
  (* Laphroig 10 year. *)
  intros d alpha k.
  functional induction (getD d alpha).
  Case "Some k0 = k0".
   intros.
   apply beq_tvar_eq in e1.
   inversion H.
   rewrite <- e1 in H2.
   rewrite <- e1 in H0.
   rewrite H4 in H2.
   rewrite H4 in H0.
   inversion H2.
   assumption.
  Case "getD d' alpha = Some k".
   intros.
   inversion H0.
   inversion H2.
   apply IHo with (d'0 := d'0) in H; try assumption.
  Case "None = Some".
   intros.
   inversion H.
Qed.

Lemma getD_extension_agreement_fun:
  forall (d : Delta) (alpha : TVar) (k : Kappa),
    getD d alpha = Some k ->
  forall (d' : Delta),
    WFD d' ->
    ExtendedByD d d' ->
    getD d' alpha = Some k.
Proof.
  intros d alpha k.
  functional induction (getD d alpha).
  intros.
  Case "alpha = b".
   apply beq_tvar_eq in e1.
   inversion H1.
   rewrite <- H2 in H1.
   rewrite <- H2 in H6.
   inversion H.
   rewrite H9 in H1.
   crush.
  Case "?".
   intros.
   apply IHo with (d'0:= d'0) in H; try assumption.
   inversion H1.
   assumption.
  Case "false".
   intros.
   inversion H.
Qed.

Lemma Duplicate_Alpha_implies_not_WFD:
  forall (d' : Delta) (alpha : TVar) (k k' : Kappa),
    getD d' alpha = Some k ->
    ~ WFD ((alpha,k') :: d').
Proof.
  intros d' alpha k k' getDder.
  unfold not.
  intros WFDder.
  inversion WFDder.
  rewrite H1 in getDder.
  inversion getDder.
Qed.

Lemma getD_weakening:
  forall (d : Delta) (alpha beta : TVar),
    getD d alpha = None ->
    getD d beta = None ->
    (beq_tvar beta alpha) = false -> (* Alpha Conversion. *)
    forall (k : Kappa),
      getD ([(alpha, k)] ++ d) beta = None.
Proof.
  intros.
  induction d.
  Case "[]".
   rewrite app_nil_r.
   unfold getD.
   rewrite H1.
   reflexivity.
 Case "a :: d".
  destruct a.
  unfold getD in H.
  fold getD in H.
  unfold getD in H0.
  fold getD in H0.
  case_eq (beq_tvar alpha t).
  intros.
  rewrite H2 in H.
  inversion H.
  intros.
  rewrite H2 in H.
  case_eq (beq_tvar beta t).
  intros.
  rewrite H3 in H0.
  inversion H0.
  intros.
  rewrite H3 in H0.
  apply IHd in H; try assumption.
  simpl.
  case_eq (beq_tvar beta alpha).
  intros.
  inversion H4.
  rewrite H1 in H4.
  discriminate.
  intros.
  rewrite H3.
  assumption.
Qed.

Lemma getD_alpha_some_beta_none:
  forall (d : Delta) (alpha : TVar) (k : Kappa),
    getD d alpha = Some k ->
    forall (beta : TVar),
      getD d beta  = None ->
      beq_tvar alpha beta = false.
Proof.
  intros.
  induction d.
  Case "[]".
   inversion H.
  Case "a :: d".
   case_eq a.
   intros.
   crush.
   case_eq (beq_tvar alpha t); case_eq (beq_tvar beta t); case_eq (beq_tvar alpha beta); intros; try reflexivity.
   (* four contradictions to invert away. *)
   rewrite H2 in H0.
   inversion H0.
   apply beq_tvar_eq in H1.
   apply beq_tvar_eq in H3.
   apply beq_tvar_neq in H2.
   rewrite H1 in H3.
   congruence.

   apply beq_tvar_eq in H1.
   apply beq_tvar_eq in H2.
   apply beq_tvar_neq in H3.
   rewrite H1 in H3.
   congruence.

   (* Can't discriminate away on this on variables.  *)
   rewrite H3 in H.
   rewrite H2 in H0.
   apply IHd in H; try assumption.
   congruence.
Qed.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli
g
*)

Require Import csubst.

Lemma simple_substc2_ex {p} :
  forall (t : @CTerm p) x u s w cu,
    !LIn x (dom_csub s)
    -> {c : cover_vars u (snoc s (x, t))
        & substc t x (lsubstc_vars u w (csub_filter s [x]) [x] cu)
          = lsubstc u w (snoc s (x, t)) c}.
Proof.
  introv ni.

  assert (cover_vars u (snoc s (x, t))) as c.
  unfold cover_vars_upto in cu.
  rw @cover_vars_eq.
  provesv.
  allrw in_app_iff; allrw in_single_iff; allrw @dom_csub_snoc; allrw in_snoc; allsimpl.
  allrw @dom_csub_csub_filter; allrw in_remove_nvars; allrw in_single_iff; sp.

  exists c.
  symmetry.
  apply simple_substc2; auto.
Qed.

Lemma simple_lsubstc_subst_ex {p} :
  forall (t : @NTerm p) x B ws s cs wt ct,
    disjoint (free_vars t) (bound_vars B)
    -> {wb : wf_term B
        & {cb : cover_vars_upto B (csub_filter s [x]) [x]
        & lsubstc (subst B x t) ws s cs
          = substc (lsubstc t wt s ct) x (lsubstc_vars B wb (csub_filter s [x]) [x] cb)}}.
Proof.
  introv disj.
  dup ws as wB.
  apply lsubst_wf_term in wB.
  exists wB.
  dup cs as cB.
  rw @cover_vars_eq in cB.

  generalize (eqvars_free_vars_disjoint B [(x,t)]); introv eqv.
  apply subvars_eqvars with (s2 := dom_csub s) in eqv; auto.
  rw subvars_app_l in eqv; repnd.
  rw subvars_remove_nvars in eqv0.
  allsimpl.
  assert (cover_vars_upto B (csub_filter s [x]) [x]) as cb.
  unfold cover_vars_upto; rw subvars_prop; introv ib.
  rw in_app_iff; rw in_single_iff.
  rw @dom_csub_csub_filter; rw in_remove_nvars; rw in_single_iff.
  rw subvars_prop in eqv0.
  apply eqv0 in ib.
  rw in_app_iff in ib.
  rw in_single_iff in ib.
  destruct (deq_nvar x0 x); subst; sp.
  exists cb.

  apply simple_lsubstc_subst; auto.
Qed.

Ltac substc_lsubstc_vars2 :=
  match goal with
    | [ |- context[substc ?t ?x (lsubstc_vars ?u ?w (csub_filter ?s [?x]) [?x] ?cu)] ] =>
      let eq := fresh "eq" in
      let h := fresh "h" in
      let c := fresh "c" in
      generalize (simple_substc2_ex t x u s w cu);
        intro eq;
        autodimp eq h;
        try (destruct eq as [c eq]; rewrite eq; clear eq)
    | [ H : context[substc ?t ?x (lsubstc_vars ?u ?w (csub_filter ?s [?x]) [?x] ?cu)] |- _ ] =>
      let eq := fresh "eq" in
      let h := fresh "h" in
      let c := fresh "c" in
      generalize (simple_substc2_ex t x u s w cu);
        intro eq;
        autodimp eq h;
        try (destruct eq as [c eq]; rewrite eq in H; clear eq)

    | [ |- context[lsubstc (subst ?B ?x ?t) ?ws ?s ?cs] ] =>
      let eq := fresh "eq" in
      let h  := fresh "h"  in
      let wb := fresh "wb" in
      let cb := fresh "cb" in
      let wt := fresh "wt" in
      let ct := fresh "ct" in
      assert (wf_term t) as wt by auto;
        assert (cover_vars t s) as ct by auto;
        generalize (simple_lsubstc_subst_ex t x B ws s cs wt ct);
        intro eq;
        autodimp eq h;
        try (destruct eq as [wb eq]; destruct eq as [cb eq]; rewrite eq; clear eq)

    | [ H : context[lsubstc (subst ?B ?x ?t) ?ws ?s ?cs] |- _ ] =>
      let eq := fresh "eq" in
      let h  := fresh "h"  in
      let wb := fresh "wb" in
      let cb := fresh "cb" in
      let wt := fresh "wt" in
      let ct := fresh "ct" in
      assert (wf_term t) as wt by auto;
        assert (cover_vars t s) as ct by auto;
        generalize (simple_lsubstc_subst_ex t x B ws s cs wt ct);
        intro eq;
        autodimp eq h;
        try (destruct eq as [wb eq]; destruct eq as [cb eq]; rewrite eq in H; clear eq)
  end.

Lemma simple_substc3 {p} :
  forall (t : @CTerm p) x u s w c cu,
    lsubstc u w ((x,t) :: s) c
    = substc t x (lsubstc_vars u w (csub_filter s [x]) [x] cu).
Proof.
  introv.

  assert (wf_term (csubst u [(x, t)])) as wc by (apply csubst_preserves_wf_term; sp).
  assert (cover_vars (csubst u [(x, t)]) s) as cc by (apply cover_vars_csubst3; simpl; sp).

  generalize (simple_substc t x u wc s cc w cu); intro eq.
  rewrite <- eq; clear eq.

  generalize (lsubstc_csubst_ex u [(x,t)] s wc cc); intro eq; exrepnd; clear_irr; allrw.
  simpl; sp.
Qed.

Lemma simple_substc3_ex {p} :
  forall (t : @CTerm p) x u s w cu,
    {c : cover_vars u ((x,t) :: s)
     & substc t x (lsubstc_vars u w (csub_filter s [x]) [x] cu)
       = lsubstc u w ((x,t) :: s) c}.
Proof.
  introv.

  assert (cover_vars u ((x,t) :: s)) as c.
  unfold cover_vars_upto in cu.
  rw @cover_vars_eq.
  provesv.
  allrw in_app_iff; allrw in_single_iff; allrw @dom_csub_snoc; allrw in_snoc; allsimpl.
  allrw @dom_csub_csub_filter; allrw in_remove_nvars; allrw in_single_iff; sp.

  exists c.
  symmetry.
  apply simple_substc3; auto.
Qed.

Ltac substc_lsubstc_vars3 :=
  match goal with
    | [ |- context[substc ?t ?x (lsubstc_vars ?u ?w (csub_filter ?s [?x]) [?x] ?cu)] ] =>
      let eq := fresh "eq" in
      let h := fresh "h" in
      let c := fresh "c" in
      generalize (simple_substc3_ex t x u s w cu);
        intro eq;
        try (destruct eq as [c eq]; rewrite eq; clear eq)
    | [ H : context[substc ?t ?x (lsubstc_vars ?u ?w (csub_filter ?s [?x]) [?x] ?cu)] |- _ ] =>
      let eq := fresh "eq" in
      let h := fresh "h" in
      let c := fresh "c" in
      generalize (simple_substc3_ex t x u s w cu);
        intro eq;
        try (destruct eq as [c eq]; rewrite eq in H; clear eq)

    | [ |- context[lsubstc (subst ?B ?x ?t) ?ws ?s ?cs] ] =>
      let eq := fresh "eq" in
      let h  := fresh "h"  in
      let wb := fresh "wb" in
      let cb := fresh "cb" in
      let wt := fresh "wt" in
      let ct := fresh "ct" in
      assert (wf_term t) as wt by auto;
        assert (cover_vars t s) as ct by auto;
        generalize (simple_lsubstc_subst_ex t x B ws s cs wt ct);
        intro eq;
        autodimp eq h;
        try (destruct eq as [wb eq]; destruct eq as [cb eq]; rewrite eq; clear eq)

    | [ H : context[lsubstc (subst ?B ?x ?t) ?ws ?s ?cs] |- _ ] =>
      let eq := fresh "eq" in
      let h  := fresh "h"  in
      let wb := fresh "wb" in
      let cb := fresh "cb" in
      let wt := fresh "wt" in
      let ct := fresh "ct" in
      assert (wf_term t) as wt by auto;
        assert (cover_vars t s) as ct by auto;
        generalize (simple_lsubstc_subst_ex t x B ws s cs wt ct);
        intro eq;
        autodimp eq h;
        try (destruct eq as [wb eq]; destruct eq as [cb eq]; rewrite eq in H; clear eq)
  end.

Lemma lsubstc_snoc_app {o} :
  forall (t : @NTerm o) s1 s2 x a w c,
    !LIn x (free_vars t)
    -> {c' : cover_vars t (s1 ++ s2)
        $ lsubstc t w (snoc s1 (x, a) ++ s2) c
           = lsubstc t w (s1 ++ s2) c'}.
Proof.
  introv ni.

  assert (cover_vars t (s1 ++ s2)) as cv.
  allrw @cover_vars_eq; allrw subvars_eq.
  introv i; applydup c in i.
  allrw @dom_csub_app; allrw @dom_csub_snoc; allsimpl; allrw in_app_iff; allrw in_snoc.
  sp; subst; sp.

  exists cv.

  pose proof (lsubstc_csubst_ex2 t s1 s2 w cv) as h; exrepnd.
  rw <- h1.

  pose proof (lsubstc_csubst_ex2 t (snoc s1 (x,a)) s2 w c) as k; exrepnd.
  rw <- k1.

  clear k1 h1.
  revert w'0 p'0.
  rw @subset_free_vars_csub_snoc; auto; introv.
  clear_irr; auto.
Qed.

Ltac lsubstc_snoc_app :=
  match goal with
    | [ H1 : !LIn ?x (free_vars ?t), H2 : context[lsubstc ?t ?w (snoc ?s1 (?x, ?a) ++ ?s2) ?c] |- _ ] =>
      let h := fresh "h" in
      let c' := fresh "c" in
      pose proof (lsubstc_snoc_app t s1 s2 x a w c H1) as h;
        destruct h as [c' h];
        rewrite h in H2;
        clear h;
        clear_irr
  end.

Ltac rw_lsubstc_subst_snoc_eq :=
  match goal with
    | [ wb : wf_term ?b
      , cb : cover_vars_upto ?b (csub_filter ?s [?x]) [?x]
      , H  : context[lsubstc (subst ?b ?x (mk_var ?y)) ?w (snoc ?s (?y, ?a)) ?c]
      |- _ ] =>
      let h := fresh "h" in
      let hh := fresh "hh" in
      pose proof (lsubstc_subst_snoc_eq s b x y a w wb c cb) as h;
        repeat (autodimp h hh);
        try (rewrite h in H; clear h)
  end.


Require Import Iron.Data.List.
Require Import Iron.Tactics.

(********************************************************************)
(** * Evaluation Contexts of lists *)
(*  A context defined by one place in a list of exps, where all
    the exps to the left of it in the list are values:
         v0 v1 v2 xx x4 x5 x6
                  ^^
    This is useful when enforcing a left-to-right evaluation
    order for a list of exps, like in the arguments of an XCon *)
Inductive exps_ctx
      {exp :Type}         (* type of expressions *)
      (Val: exp -> Prop)  (* predicate to determine whether the exp a value *)
   :  (exp -> list exp)   (* fn to fill the hole in the list evaluation context *)
   -> Prop :=
 | XscHead
   :  forall xs
   ,  exps_ctx Val (fun xx => xx :: xs)

 | XscCons
   :  forall v C
   ,  Val v
   -> exps_ctx Val C
   -> exps_ctx Val (fun xx => v :: C xx).

Hint Constructors exps_ctx.

(* Swapping related expresions in contexts *)
Lemma exps_ctx_Forall2_swap
 :  forall {exp: Type} {B:   Type}
           (Val:  exp -> Prop)
           (R:    exp -> B -> Prop)
           (C:    exp -> list exp)
           (x x': exp)
           (ys:   list B)
 ,  exps_ctx Val C
 -> (forall y, R x y -> R x' y)
 -> Forall2 R (C x)  ys
 -> Forall2 R (C x') ys.
Proof.
 intros. gen ys.
 induction H; intros.
  destruct ys.
   inverts H1.
   eapply Forall2_cons. eapply H0.
    inverts H1. auto.
    inverts H1. auto.

  inverts H2.
   eapply Forall2_cons.
   auto. auto.
Qed.

(* If all the elements in a list context have a property then
   then they also have this property individually. *)
Lemma exps_ctx_Forall
 :  forall {exp: Type}
           (Val: exp -> Prop)
           (C:   exp -> list exp)
           (P:   exp -> Prop)
           (x:   exp)
 ,  exps_ctx Val C
 -> Forall P (C x)
 -> P x.
Proof.
 intros.
 induction H.
  inverts H0. auto.
  inverts H0. auto.
Qed.

Lemma exps_ctx_Forall2_exists_left
 :  forall {exp: Type} {B: Type}
           (Val: exp -> Prop)
           (C:   exp -> list exp)
           (R:   exp -> B -> Prop)
           (x:   exp)
           (ys:  list B)
 ,  exps_ctx Val C
 -> Forall2 R (C x) ys
 -> (exists y, R x y).
Proof.
 intros. gen ys.
 induction H; intros.
  destruct ys.
   inverts H0.
   inverts H0. eauto.
  inverts H1.
  eapply IHexps_ctx. eauto.
Qed.

(* Used when evaluating all the expressions in a list.
   If all the exps in a list are either wnf or have some property,
   then they're either all wnf
     or there is a context consisting of a run of wnf expressions
        followed by one with the property.
   For example:
     C = w1 w2 w3 w4 x1 ?? ?? ?? ??
   This is a context consisting of a run of four wnfs, followed
   by an expression x1 with the desired property. The rest may or
   may not be wnfs, but the'll all have the property.
*)
Lemma exps_ctx_run
 :  forall {exp: Type} {B: Type}
           (Val:  exp -> Prop)
           (P:    exp -> Prop)
           (xs:   list exp)
 ,  Forall (fun x => Val x \/ P x) xs
 -> Forall Val xs
 \/ (exists C x', exps_ctx Val C
               /\ xs = C x'
               /\ P x').
Proof.
 intros.
 induction xs.
  left. auto.
  inverts H.

  inverts H2.
   lets D: IHxs H3. clear IHxs.
   inverts D.
    left. auto.
    right.
     destruct H0 as [C].
     destruct H0 as [x'].
      inverts H0. inverts H2.
      lets D2: (@XscCons exp Val) H H1.
      exists (fun xx => a :: C xx).
      exists x'. auto.

    lets D: IHxs H3. clear IHxs.
    inverts D.
     right.
     lets D2: (@XscHead exp Val) xs.
     exists (fun xx => xx :: xs).
     exists a. auto.

    destruct H0 as [C].
    destruct H0 as [x'].
     inverts H0. inverts H2.
     right.
     exists (fun xx => xx :: C x').
     exists a.
     lets D2: (@XscHead exp Val) (C x').
     auto.
Qed.

(********************************************************************)
(* Joint contexts of lists.
   This is used when we evaluate a list of expressions left to right
   where each expression needs to be a value before we move onto
   the next one. *)
Inductive exps_ctx2
      {exp: Type}        (* type of expressions *)
      (Val: exp -> Prop) (* predicate to determine whether an exp is a value *)
   :  (exp -> list exp)  (* fn for first  evaluation context *)
   -> (exp -> list exp)  (* fn for second evaluation context *)
   -> Prop :=
 | Xsc2Head
   :  forall xs ys
   ,  exps_ctx2 Val (fun xx => xx :: xs)  (fun yy => yy :: ys)

 | Xsc2Cons
   :  forall v C1 C2
   ,  Val v
   -> exps_ctx2 Val C1 C2
   -> exps_ctx2 Val (fun xx => v :: C1 xx) (fun yy => v :: C2 yy).

Hint Constructors exps_ctx2.

(* Take the left of a joint context *)
Lemma exps_ctx2_left
 : forall exp Val C1 C2
 , @exps_ctx2 exp Val C1 C2 -> @exps_ctx exp Val C1.
Proof.
 intros.
 induction H; auto.
Qed.

(* Take the right of a joint context *)
Lemma exps_ctx2_right
 : forall exp Val C1 C2
 , @exps_ctx2 exp Val C1 C2 -> @exps_ctx exp Val C2.
Proof.
 intros.
 induction H; auto.
Qed.

(* Used when evaluating a list of expressions.
   We take an expression from the first list, evaluate it, and
   place the result in the second. For this to happen we need
   to find an appropriate joint evaluation context.
   If we can produce a wnf for every expression in the first list,
   then either all exps are already wnf
     or we can find a joint context consisting of a run of wnf
        expressions, followed by an expression that we can evaluate.

   For example:
    C1 =  w1 w2 w3 x4 ?? ?? ??
    C2 =  w1 w2 w3 w4 ?? ?? ??
   Here we have such a joint context. The first three values in
   each are idential and already wnf. We then have x4 and y4,
   where x4 can be evaluated into y4. The rest may or may not
   be wnfs, but the'll still be related.
   v1 v2 v3 v4 XX x6 x7 x8 x9
   v1 v2 v3 v4 XX v6 v7 v8 v
*)
Lemma exps_ctx2_run
 :   forall {exp:   Type}
            (Val:   exp -> Prop)
            (R:     exp -> exp -> Prop)
            (xs ys: list exp)
 ,   Forall2 (fun x y => R x y /\ Val y /\ (Val x -> y = x)) xs ys
 ->  Forall Val xs
 \/ (exists C1 C2 x' y'
         ,  R x' y'
         /\ exps_ctx2 Val C1 C2
         /\ xs = C1 x'
         /\ ys = C2 y').
Proof.
 intros exp Val R xs ys HR.
 induction HR.
  Case "nil".
   left. auto.

  Case "cons".
   rename l  into xs.
   rename l' into ys.
   inverts H. inverts H1.
   inverts IHHR.
   SCase "xs whnf".
    right.
    exists (fun xx => xx :: xs).
    exists (fun xx => xx :: ys).
    exists x.
    exists y. auto.

   SCase "xs ctx".
    right.
    destruct H1 as [C1].
    destruct H1 as [C2].
    destruct H1 as [x'].
    destruct H1 as [y'].
    inverts H1. inverts H4. inverts H5.

    exists (fun xx => xx :: C1 x').
    exists (fun yy => yy :: C2 y').
    exists x. exists y.
    repeat (split; auto).
Qed.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype seq ssrnat.
Require Import ssrZ ZArith_ext seq_ext uniq_tac machine_int multi_int.
Import MachineInt.
Require Import mips_seplog mips_tactics mips_contrib mips_tactics mapstos.
Require Import multi_sub_u_u_prg.
Import expr_m.
Import assert_m.

Local Open Scope machine_int_scope.
Local Open Scope heap_scope.
Local Open Scope uniq_scope.
Local Open Scope mips_expr_scope.
Local Open Scope mips_assert_scope.
Local Open Scope mips_cmd_scope.
Local Open Scope mips_hoare_scope.
Local Open Scope multi_int_scope.
Local Open Scope zarith_ext_scope.

Section multi_sub.

Variables k a b t j u bor atmp btmp' : reg.

Lemma multi_sub_u_u_R_triple : uniq(k, a, b, t, j, u, bor, atmp, btmp', r0) ->
  forall nk va vb, u2Z vb + 4 * Z_of_nat nk < \B^1 ->
  forall A B, size A = nk -> size B = nk ->
  {{ fun s h => [a]_s = va /\ [b]_s = vb /\
    u2Z [k]_s = Z_of_nat nk /\ (var_e a |--> A ** var_e b |--> B) s h }}
  multi_sub_u_u k a b b t j u bor atmp btmp'
  {{ fun s h => exists B', size B' = nk /\ [a]_s = va /\
    [b]_s = vb /\ u2Z [k]_s = Z_of_nat nk /\
    (var_e a |--> A ** var_e b |--> B') s h /\
    u2Z [bor]_s <= 1 /\
    \S_{ nk } B' = \S_{ nk } A - \S_{ nk } B + u2Z [bor]_s * \B^nk }}.
Proof.
move=> Hset nk va vb Hnb A B Ha Hb; rewrite /multi_sub_u_u.

(** addiu j zero zero16; *)

NextAddiu.
move=> s h [Hra [Hrb [Hrk H]]].
rewrite /wp_addiu; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

(** addi t c zero16 *)

NextAddiu.
move=> s h [[Hra [Hrb [Hrk H]]] Hj].
rewrite /wp_addiu; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

(** addi bor zero zero16; *)

NextAddiu.
move=> s h [[[Hra [Hrb [Hrk H]]] Hj] Ht].
rewrite /wp_addiu; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

(** while (bne j k) ( *)

apply hoare_prop_m.hoare_while_invariant with (fun s h => exists B' nj nbor,
  size B' = nk /\ [a]_s = va /\ [b]_s = vb /\ u2Z [k]_s = Z_of_nat nk /\
  (var_e a |--> A ** var_e b |--> B') s h /\
  u2Z [j]_s = Z_of_nat nj /\ (nj <= nk)%nat /\
  u2Z [t]_s = u2Z vb + 4 * Z_of_nat nj /\ u2Z [bor]_s = nbor /\
  nbor <= 1 /\ \S_{ nj } B' = \S_{ nj } A - \S_{ nj } B + nbor * \B^nj /\
  drop nj B = drop nj B').

move=> s h [[[[Hra [Hrb [Hrk H]]] Hj] Ht Hbor]].

exists B, O, 0; repeat (split => //).
by rewrite Hj store.get_r0 add0i sext_Z2u // Z2uK.
rewrite Ht sext_0 addi0 Hrb; ring.
by rewrite Hbor sext_0 addi0 store.get_r0 Z2uK.

move=> s h [[B' [nj [nbor [HlenC [Hra [Hrb [Hrk [Hmem [Hrj [Hjk2 [Hrt [Hrbor [Hnbor [HInv Hnth]]]]]]]]]]]]] Hjk]];
  rewrite /= in Hjk. move/negPn/eqP in Hjk.
exists B'; repeat (split; trivial).
by rewrite Hrbor.
have -> : nk = nj by rewrite Hrj Hrk in Hjk; exact: Z_of_nat_inj.
by rewrite Hrbor -HInv.

(** lwxs atmp j b; *)

apply hoare_lwxs_back_alt'' with (fun s h => exists B' nj nbor,
  size B' = nk /\ [a]_s = va /\ [b]_s = vb /\ u2Z [k]_s = Z_of_nat nk /\
  (var_e a |--> A ** var_e b |--> B') s h /\
  u2Z [j]_s = Z_of_nat nj /\ (nj < nk)%nat /\
  u2Z [t]_s = u2Z vb + 4 * Z_of_nat nj /\ u2Z [bor]_s = nbor /\ nbor <= 1 /\
  \S_{ nj } B' = \S_{ nj } A - \S_{ nj } B + nbor * \B^nj /\ drop nj B = drop nj B' /\
  [atmp]_s = B `32_ nj).

move=> s h [[B' [nj [nbor [HlenC [Hra [Hrb [Hrk [Hmem [Hrj [Hjk2 [Hrt [Hrbor [Hnbor [HInv Hnth]]]]]]]]]]]]] Hjk]];
  rewrite /= in Hjk. move/eqP in Hjk.

have {}Hjk : (nj < nk)%nat.
  rewrite ltn_neqAle Hjk2 andbT; apply/eqP.
  rewrite Hrj Hrk in Hjk.
  contradict Hjk; by rewrite Hjk.

exists (B' `32_ nj); split.
- Decompose_32 B' nj B'1 B'2 HlenB1 HB'; last by rewrite HlenC.
  rewrite HB' (decompose_equiv _ _ _ _ _ HlenB1) in Hmem.
  rewrite assert_m.conCE !assert_m.conAE in Hmem.
  rewrite assert_m.conCE !assert_m.conAE in Hmem.
  move: Hmem; apply monotony => // h'.
  apply mapsto_ext => //.
  by rewrite /= shl_Z2u Hrj inj_mult mulZC.
- rewrite /update_store_lwxs.
  exists B', nj, nbor; repeat Reg_upd; repeat (split; trivial).
  by Assert_upd.
  rewrite (drop_nth zero32) in Hnth; last by rewrite Hb.
  symmetry in Hnth.
  rewrite (drop_nth zero32) in Hnth; last by rewrite HlenC.
  by case: Hnth.

(** addu btmp' atmp bor; *)

apply hoare_addu with (fun s h => exists B' nj nbor,
  size B' = nk /\ [a]_s = va /\ [b]_s = vb /\ u2Z [k]_s = Z_of_nat nk /\
  (var_e a |--> A ** var_e b |--> B') s h /\
  u2Z [j]_s = Z_of_nat nj /\ (nj < nk)%nat /\
  u2Z [t]_s = u2Z vb + 4 * Z_of_nat nj /\ u2Z [bor]_s = nbor /\
  nbor <= 1 /\ \S_{ nj } B' = \S_{ nj } A - \S_{ nj } B + nbor * \B^nj /\
  drop nj B = drop nj B' /\
  [atmp]_s = B `32_ nj /\ [btmp']_s = B `32_ nj `+ [bor]_s).

move=> s h [B' [nj [nbor [HlenC [Hra [Hrb [Hrk [Hmem [Hrj [Hjk2 [Hrt [Hrbor [Hnbor [HInv [Hnth Hratmp]]]]]]]]]]]]]]].
exists B', nj, nbor; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite -Hratmp.

(** sltu u btmp' atmp; *)

apply hoare_sltu with (fun s h => exists B' nj nbor,
  size B' = nk /\ [a]_s = va /\ [b]_s = vb /\ u2Z [k]_s = Z_of_nat nk /\
  (var_e a |--> A ** var_e b |--> B') s h /\
  u2Z [j]_s = Z_of_nat nj /\ (nj < nk)%nat /\
  u2Z [t]_s = u2Z vb + 4 * Z_of_nat nj /\ u2Z [bor]_s = nbor /\ nbor <= 1 /\
  \S_{ nj } B' = \S_{ nj } A - \S_{ nj } B + nbor * \B^nj /\
  drop nj B = drop nj B' /\
  [btmp']_s = B `32_ nj `+ [bor]_s /\
  [u]_s = if Zlt_bool (u2Z [btmp']_s) (u2Z (B `32_ nj)) then one32 else zero32).

move=> s h [B' [nj [nbor [HlenC [Hra [Hrb [Hrk [Hmem [Hrj [Hjk2 [Hrt [Hrbor [Hnbor [HInv [Hnth [Hratmp Hrbtmp']]]]]]]]]]]]]]]].
exists B', nj, nbor; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite -Hratmp.

(** lwxs atmp j a; *)

apply hoare_lwxs_back_alt'' with (fun s h => exists B' nj nbor,
  size B' = nk /\ [a]_s = va /\ [b]_s = vb /\ u2Z [k]_s = Z_of_nat nk /\
  (var_e a |--> A ** var_e b |--> B') s h /\
  u2Z [j]_s = Z_of_nat nj /\ (nj < nk)%nat /\
  u2Z [t]_s = u2Z vb + 4 * Z_of_nat nj /\ u2Z [bor]_s = nbor /\ nbor <= 1 /\
  \S_{ nj } B' = \S_{ nj } A - \S_{ nj } B + nbor * \B^nj  /\
  drop nj B = drop nj B' /\ [atmp]_s = A `32_ nj /\
  [btmp']_s = B `32_ nj `+ [bor]_s /\
  [u]_s = if Zlt_bool (u2Z [btmp']_s) (u2Z (B `32_ nj)) then one32 else zero32).

move=> s h [B' [nj [nbor [HlenC [Hra [Hrb [Hrk [Hmem [Hrj [Hjk2 [Hrt [Hrbor [Hnbor [HInv [Hnth [Hrbtmp' Hru]]]]]]]]]]]]]]]].

exists (A `32_ nj); split.
- Decompose_32 A nj A1 A2 HlenA1 HA'; last by rewrite Ha.
  rewrite HA' (decompose_equiv _ _ _ _ _ HlenA1) !assert_m.conAE assert_m.conCE !assert_m.conAE in Hmem.
  move: Hmem; apply monotony => // h'.
  apply mapsto_ext => //.
  by rewrite /= shl_Z2u Hrj inj_mult mulZC.
- rewrite /update_store_lwxs.
  exists B', nj, nbor; repeat Reg_upd; repeat (split; trivial).
  by Assert_upd.

(** ifte_beq u, zero thendo *)

apply while.hoare_seq with (fun s h => exists B' nj nbor,
  size B' = nk /\ [a]_s = va /\ [b]_s = vb /\ u2Z [k]_s = Z_of_nat nk /\
  (var_e a |--> A ** var_e b |--> B') s h /\
  u2Z [j]_s = Z_of_nat nj /\ (nj < nk)%nat /\
  u2Z [t]_s = u2Z vb + 4 * Z_of_nat nj /\
  drop nj B = drop nj B' /\ u2Z [bor]_s = nbor /\ nbor <= 1 /\
  \S_{ nj } B' + u2Z [atmp]_s * \B^nj =
  \S_{ nj } A - \S_{ nj } B + u2Z (A `32_ nj) * \B^nj - u2Z (B `32_ nj) * \B^nj + nbor * \B^nj.+1).

apply while.hoare_ifte.

(** addiu u r0 one16; *)

apply hoare_addiu with (fun s h => exists B' nj nbor,
  size B' = nk /\ [a]_s = va /\ [b]_s = vb /\ u2Z [k]_s = Z_of_nat nk /\
  (var_e a |--> A ** var_e b |--> B') s h /\
  [u]_s = one32 /\ u2Z [j]_s = Z_of_nat nj /\ (nj < nk)%nat /\
  u2Z [t]_s = u2Z vb + 4 * Z_of_nat nj /\ u2Z [bor]_s = nbor /\
  nbor <= 1 /\ \S_{ nj } B' = \S_{ nj } A - \S_{ nj } B + nbor * \B^nj /\
  [atmp]_s = A `32_ nj /\
  drop nj B = drop nj B' /\ [btmp']_s = B `32_ nj `+ [bor]_s /\
  u2Z [btmp']_s = u2Z (B `32_ nj) + nbor).

move=> s h [[B' [nj [nbor [HlenC [Hra [Hrb [Hrk [Hmem [Hrj [Hjk2 [Hrt [Hrbor [Hnbor [HInv [Hnth [Hratmp [Hrbtmp' Hru]]]]]]]]]]]]]]]]] Huzero]; rewrite /= in Huzero.

exists B', nj, nbor; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite add0i sext_Z2u.
rewrite Hrbtmp' -Hrbor u2Z_add //.
have X : u2Z (B `32_ nj) <= u2Z [btmp']_s.
  rewrite leZNgt => /ltZP X.
  by rewrite Hru X /zero32 /one32 ?Z2uK in Huzero.
rewrite Hrbtmp' in X; by move/u2Z_add_no_overflow in X.

(** multu atmp one; *)

apply hoare_multu with (fun s h => exists B' nj nbor,
  size B' = nk /\ [a]_s = va /\ [b]_s = vb /\ u2Z [k]_s = Z_of_nat nk /\
  (var_e a |--> A ** var_e b |--> B') s h /\
  [u]_s = one32 /\ u2Z [j]_s = Z_of_nat nj /\ (nj < nk)%nat /\
  u2Z [t]_s = u2Z vb + 4 * Z_of_nat nj /\ u2Z [bor]_s = nbor /\
  nbor <= 1 /\ \S_{ nj } B' = \S_{ nj } A - \S_{ nj } B + nbor * \B^nj /\
  [atmp]_s = A `32_ nj /\
  drop nj B = drop nj B' /\ [btmp']_s = B `32_ nj `+ [bor]_s /\
  u2Z [btmp']_s = u2Z (B `32_ nj) + nbor /\ store.utoZ s = u2Z (A `32_ nj)).

move=> s h [B' [nj [nbor [HlenC [Hra [Hrb [Hrk [Hmem [Hrone [Hrj [Hjk2 [Hrt [Hrbor [Hnbor [HSum [Hnth [Hratmp [Hrbtmp' Hru]]]]]]]]]]]]]]]]]].

exists B', nj, nbor; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite store.utoZ_multu Hrone umul_1 (@u2Z_zext 32) Hnth.

(** msubu btmp' one; *)

apply hoare_msubu with (fun s h => exists B' nj nbor,
  size B' = nk /\ [a]_s = va /\ [b]_s = vb /\ u2Z [k]_s = Z_of_nat nk /\
  (var_e a |--> A ** var_e b |--> B') s h /\
  [u]_s = one32 /\ u2Z [j]_s = Z_of_nat nj /\ (nj < nk)%nat /\
  u2Z [t]_s = u2Z vb + 4 * Z_of_nat nj /\ u2Z [bor]_s = nbor /\
  nbor <= 1 /\ \S_{ nj } B' = \S_{ nj } A - \S_{ nj } B + nbor * \B^nj /\
  [atmp]_s = A `32_ nj /\
  drop nj B = drop nj B' /\ [btmp']_s = B `32_ nj `+ [bor]_s /\
  u2Z [btmp']_s = u2Z (B `32_ nj) + nbor /\
  ((u2Z [btmp']_s <= u2Z (A `32_ nj) -> store.utoZ s = u2Z (A `32_ nj) - u2Z [btmp']_s) /\
   (u2Z (A `32_ nj) < u2Z [btmp']_s -> store.utoZ s = \B^2 + u2Z (A `32_ nj) - u2Z [btmp']_s))).

move=> s h [B' [nj [nbor [HlenC [Hra [Hrb [Hrk [Hmem [Hone [Hrj [Hjk [Hrt [Hrbor [Hnbor [Hinv [Hratmp [Hnth [Hrbtmp' [Hrbtmp'2 Hm]]]]]]]]]]]]]]]]]]].
exists B'; exists nj; exists nbor.
rewrite Hone umul_1.
repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
move=> H; rewrite store.msubu_utoZ Hm ?(@u2Z_zext 32) //.
apply (@ltZ_trans \B^1) => //.
exact: max_u2Z.
exact: Z.le_ge.
move=> H; rewrite store.msubu_utoZ_overflow Hm ?(@u2Z_zext 32) //.
apply (@ltZ_trans \B^1) => //; exact: max_u2Z.

(** sltu bor atmp btmp'; *)

apply hoare_sltu with (fun s h => exists B' nj nbor,
  size B' = nk /\ [a]_s = va /\ [b]_s = vb /\ u2Z [k]_s = Z_of_nat nk /\
  (var_e a |--> A ** var_e b |--> B') s h /\
  u2Z [j]_s = Z_of_nat nj /\ (nj < nk)%nat /\
  u2Z [t]_s = u2Z vb + 4 * Z_of_nat nj /\ nbor <= 1 /\
  \S_{ nj } B' = \S_{ nj } A - \S_{ nj } B + nbor * \B^nj /\
  [atmp]_s = A `32_ nj /\
  drop nj B = drop nj B' /\
  [btmp']_s = B `32_ nj `+ Z2u 32 nbor /\
  u2Z [btmp']_s = u2Z (B `32_ nj) + nbor /\
  (u2Z [btmp']_s <= u2Z (A `32_ nj) -> store.utoZ s = u2Z (A `32_ nj) - u2Z [btmp']_s) /\
  (u2Z (A `32_ nj) < u2Z [btmp']_s -> store.utoZ s = \B^2 + u2Z (A `32_ nj) - u2Z [btmp']_s) /\
  [bor]_s = if u2Z (A `32_ nj) <? u2Z [btmp']_s then one32 else zero32).

move=> s h [B' [nj [nbor [HlenC [Hra [Hrb [Hrk [Hmem [Hone [Hrj [Hjk [Hrt [Hrbor [Hnbor [Hinv [Hratmp [Hnth [Hrbtmp' [Hrbtmp'2 [Hinv1 Hinv2]]]]]]]]]]]]]]]]]]]].

exists B', nj, nbor; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite -Hrbor Z2u_u2Z.
by rewrite -Hratmp.

(** mflhxu atmp *)

apply hoare_mflhxu'.
move=> s h [B' [nj [nbor [HlenC [Hra [Hrb [Hrk [Hmem [Hrj [Hjk [Hrt [Hnbor [Hinv [Hratmp [Hnth [Hrbtmp' [Hrbtmp'2 [Hm1 [Hm2 Hrbor]]]]]]]]]]]]]]]]]]].

case: (Z_lt_le_dec (u2Z (A `32_ nj)) (u2Z [btmp']_s)).
- move/ltZP => X.
  rewrite X in Hrbor.
  move/ltZP in X.
  exists B', nj, (u2Z one32).
  repeat Reg_upd; repeat (split; trivial).
  by Assert_upd.
  by rewrite Hrbor.
  by rewrite Z2uK.
  move: {Hm1 Hm2}(Hm2 X) => Hm.
  have Hacx0 : store.acx s = Z2u store.acx_size 0.
    apply store.utoZ_acx_beta2.
    rewrite Hm; lia.
  rewrite store.utoZ_def Hacx0{Hacx0} Z2uK // mul0Z addZ0 in Hm.
  rewrite (_ : \B^2 = \B^1 * (\B^1 - 1) + \B^1) // addZC (mulZC (\B^1)) in Hm.
  rewrite (_ : forall a b c d, a + b + c - d = a + (b + c - d)) in Hm; last by move=> *; ring.
  apply poly_eq_inv in Hm; last first.
    rewrite Zbeta1E.
    split; first exact: min_u2Z.
    split.
    by split; [apply min_u2Z | apply max_u2Z].
    split; first by [].
    move: (min_u2Z (A `32_ nj)) (max_u2Z [btmp']_s) => ? ?; lia.
  case: Hm => _ Hm.
  rewrite Hinv Hm (Zbeta_S nj) Hrbtmp'2 Z2uK //; ring.
- move/leZNgt/ltZP/negbTE => X.
  rewrite X in Hrbor.
  move/ltZP/leZNgt in X.
  exists B', nj, (u2Z zero32).
  repeat Reg_upd; repeat (split; trivial).
  by Assert_upd.
  by rewrite Hrbor.
  by rewrite Z2uK.
  move: {Hm1 Hm2}(Hm1 X) => Hm.
  have H0 : store.utoZ s < \B^1.
    move: (max_u2Z (A `32_ nj)) (min_u2Z [btmp']_s).
    rewrite Hm -Zbeta1E => ? ?; lia.
  case/store.utoZ_lo_beta1 : H0 => _ [_ <-].
  rewrite Hinv Hm Hrbtmp'2 Z2uK //; ring.

(** nop); *)

apply hoare_nop'.

(** we are in the branch where btmp' = atmp + bor has overflowed *)

move=> s h [[B' [nj [nbor [HlenC [Hra [Hrb [Hrk [Hmem [Hrj [Hjk [Hrt [Hrbor [Hnbor [Hinv [Hnth [Hratmp [Hrbtmp' Hru]]]]]]]]]]]]]]]] Huzero]];
  rewrite /= in Huzero. move/negbTE/eqP in Huzero.
exists B', nj, nbor.
repeat Reg_upd.
repeat (split; trivial).
have [X1 X2] : nbor = 1 /\ u2Z (B `32_ nj) = \B^1 - 1.
  have H : u2Z [btmp']_s < u2Z (B `32_ nj).
    apply/ltZP.
    apply: Bool.not_false_is_true => X.
    by rewrite Hru X in Huzero.
  rewrite Hrbtmp' in H.
  apply u2Z_add_overflow' in H; rewrite -Zbeta1E in H.
  move: (max_u2Z (B `32_ nj)) => H'; rewrite -Zbeta1E in H'; lia.
rewrite Hratmp Hinv X1 X2 !mul1Z (Zbeta_S nj); ring.

(** sw ctmp zero16 t; *)

apply hoare_sw_back'' with (fun s h => exists B' nj nbor,
  size B' = nk /\ [a]_s = va /\ [b]_s = vb /\ u2Z [k]_s = Z_of_nat nk /\
  (var_e a |--> A ** var_e b |--> B') s h /\
  u2Z [j]_s = Z_of_nat nj /\ (nj < nk)%nat /\
  u2Z [t]_s = u2Z vb + 4 * Z_of_nat nj /\ u2Z [bor]_s = nbor /\
  nbor <= 1 /\ \S_{nj.+1} B' = \S_{nj.+1} A - \S_{nj.+1} B + nbor * \B^nj.+1 /\
  drop nj.+1 B = drop nj.+1 B').

move=> s h [B' [nj [nbor [HlenB' [Hra [Hrb [Hrk [Hmem [Hrj [Hjk [Hrt [Hnth [Hrbor [Hnbor Hinv]]]]]]]]]]]]]].

have Htmp : [ var_e t \+ int_e (sext 16 zero16) ]e_s = [ var_e b \+ int_e (Z2u 32 (Z_of_nat (4 * nj))) ]e_ s.
  rewrite /= sext_Z2u // addi0.
  apply u2Z_inj.
  rewrite u2Z_add_Z_of_nat.
  rewrite inj_mult Hrt Hrb; ring.
  rewrite inj_mult -Zbeta1E Hrb; simpl Z_of_nat; move/ltP in Hjk; lia.

exists (int_e (B' `32_ nj)).

Decompose_32 B' nj B'1 B'2 HlenB'1 HB'; last by rewrite HlenB'.

rewrite HB' (decompose_equiv _ _ _ _ _ HlenB'1) in Hmem.
rewrite assert_m.conCE !assert_m.conAE in Hmem.
rewrite assert_m.conCE !assert_m.conAE in Hmem.
move: Hmem; apply monotony => // ht.
exact: mapsto_ext.
apply currying => h' H'; simpl app in H'.
exists (upd_nth B' nj [atmp]_s); exists nj, nbor.
repeat (split; trivial).
exact: size_upd_nth.
rewrite HB' upd_nth_cat HlenB'1 // subnn /= (decompose_equiv _ _ _ _ _ HlenB'1).
rewrite cat0s in H'.
assoc_comm H'.
exact: mapsto_ext H'.

rewrite HB' -cat1s catA upd_nth_cat'; last first.
  rewrite size_cat/= HlenB'1 addnC /=; exact/ltP/lt_n_Sn.
rewrite upd_nth_cat; last first.
  by rewrite HlenB'1.
rewrite HlenB'1 subnn; simpl upd_nth; simpl app; rewrite -lSum_beyond; last first.
  by rewrite size_cat /= HlenB'1 addnC.
rewrite (lSum_cut_last _ B'1) //; last first.
  by rewrite size_cat /= HlenB'1 addnC.
rewrite subn1 [_.+1.-1]/=.

rewrite HB' -lSum_beyond // in Hinv.
rewrite -/(\B^nj) mulZC Hinv.

Decompose_32 A nj A1 A2 HlenA1 HA'; last by rewrite Ha.

rewrite {3}HA' -cat1s catA -lSum_beyond; last first.
  by rewrite size_cat /= HlenA1 addnC.
rewrite (lSum_cut_last _ A1) //; last by rewrite size_cat/= HlenA1 addnC.
rewrite -/(_ `32_ nj) subn1 [_.+1.-1]/=.

Decompose_32 B nj B1 B2 HlenB1 HB_; last by rewrite Hb.
rewrite {3}HB_ -(cat1s (B `32_ nj)) catA -lSum_beyond //; last first.
  by rewrite size_cat /= HlenB1 addnC.
rewrite (lSum_cut_last _ B1) //; last by rewrite size_cat /= HlenB1 addnC.
rewrite -/(_ `32_ nj) subn1 [_.+1.-1]/= HA' -lSum_beyond //.
rewrite ( _ : (A1 ++ (A `32_ nj :: A2)) `32_ nj = A `32_ nj); last first.
  by rewrite /nth' nth_cat HlenA1 ltnn subnn /=.
rewrite  HB_ -lSum_beyond //.
rewrite ( _ : (B1 ++ (B `32_ nj :: B2)) `32_ nj = B `32_ nj); last first.
  by rewrite /nth' nth_cat HlenB1 ltnn subnn /=.
rewrite -ZbetaE /=; ring.

rewrite drop_upd_nth //.
rewrite (drop_nth zero32) in Hnth; last by rewrite Hb.
symmetry in Hnth.
rewrite (drop_nth zero32) in Hnth; last by rewrite HlenB'.
by case: Hnth.

(** addiu t t four16; *)

apply hoare_addiu with (fun s h => exists B' nj nbor,
 length B' = nk /\ [a]_s = va /\ [b]_s = vb /\
 u2Z [k]_s = Z_of_nat nk /\ (var_e a |--> A ** var_e b |--> B') s h /\
 u2Z [j]_s = Z_of_nat nj /\ (nj < nk)%nat /\
 u2Z [t]_s = u2Z vb + 4 * (Z_of_nat nj + 1) /\ u2Z [bor]_s = nbor /\ nbor <= 1 /\
 \S_{nj.+1} B' = \S_{nj.+1} A - \S_{nj.+1} B + nbor * \B^nj.+1 /\ drop nj.+1 B = drop nj.+1 B').

move=> s h [B' [nj [nbor [HlenC [Hra [Hrb [Hrk [Hmem [Hrj [Hjk [Hrt [Hbor [Hnbor [Hinv Hnth]]]]]]]]]]]]]].

move/ltP in Hjk.
exists B', nj, nbor; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
exact/ltP.
rewrite u2Z_add sext_Z2u // Z2uK //.
- lia.
- rewrite -Zbeta1E; lia.

(** addiu j j one16 *)

apply hoare_addiu'.
move=> s h [B' [nj [nbor [HlenC [Hra [Hrb [Hrk [Hmem [Hrj [Hjk [Hrt [Hbor [Hnbor [Hinv Hnth]]]]]]]]]]]]]].

exists B', nj.+1, nbor.
rewrite Z_S.
repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

rewrite sext_Z2u // u2Z_add_Z2u //.
by rewrite Hrj.
move/ltP in Hjk.
move: (min_u2Z vb) => ?; rewrite -Zbeta1E; lia.
Qed.

Lemma multi_sub_u_u_R_triple_B_le_A : uniq(k, a, b, t, j, u, bor, atmp, btmp', r0) ->
  forall nk va vb, u2Z vb + 4 * Z_of_nat nk < \B^1 ->
  forall A B, size A = nk -> size B = nk -> \S_{ nk } B <= \S_{ nk } A ->
  {{ fun s h =>
    [a]_s = va /\ [b]_s = vb /\
    u2Z [k]_s = Z_of_nat nk /\ (var_e a |--> A ** var_e b |--> B) s h }}
  multi_sub_u_u k a b b t j u bor atmp btmp'
  {{ fun s h => exists B', size B' = nk /\ [a]_s = va /\
    [b]_s = vb /\ u2Z [k]_s = Z_of_nat nk /\ [bor]_s = zero32 /\
    (var_e a |--> A ** var_e b |--> B') s h /\
    \S_{ nk } B' = \S_{ nk } A - \S_{ nk } B }}.
Proof.
move=> Hset nk va vb Hna A B Ha Hb HAB.
eapply hoare_prop_m.hoare_weak; last by eapply multi_sub_u_u_R_triple; eauto.
move=> s h [A' [HlenA [Hra [Hrb [Hrk [Hmem [Hbor Hsum]]]]]]].
have X : u2Z [bor]_s = 0.
  have {}Hsum : u2Z [bor ]_ s * \B^nk + (\S_{ nk } A - \S_{ nk } B - \S_{ nk } A') = 0 * \B^nk + 0.
    rewrite Hsum; ring.
  apply poly_eq0_inv in Hsum.
  tauto.
  exact: expZ_ge0.
  move: (min_lSum nk B) (min_lSum nk A') (max_lSum nk A) (max_lSum nk A') => ????.
  rewrite ZbetaE; lia.
exists A'; repeat (split => //).
rewrite (_ : 0 = u2Z zero32) in X; last by rewrite Z2uK.
by move/u2Z_inj : X.
rewrite Hsum X mul0Z addZ0; reflexivity.
Qed.

End multi_sub.


Require Import List.
Import ListNotations.
Require Import Arith.

Require Import VerdiTactics.
Require Import Util.
Require Import Net.
Require Import Raft.
Require Import RaftRefinement.

Require Import CommonTheorems.

Require Import UpdateLemmas.
Local Arguments update {_} {_} {_} _ _ _ _ : simpl never.

Section CroniesTerm.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition cronies_term (net : network) :=
    forall h h' t,
      In h (cronies (fst (nwState net h')) t) ->
      t <= currentTerm (snd (nwState net h')).

  Ltac update_destruct :=
    match goal with
      | [ |- context [ update _ ?y _ ?x ] ] => destruct (@name_eq_dec _ _ y x)
    end.

  Lemma handleClientRequest_spec :
    forall h st id c out st' l,
      handleClientRequest h st id c = (out, st', l) ->
      currentTerm st' = currentTerm st.
  Proof.
    intros. unfold handleClientRequest in *.
    break_match; find_inversion; intuition.
  Qed.

  Lemma cronies_term_client_request :
    refined_raft_net_invariant_client_request cronies_term.
  Proof.
    unfold refined_raft_net_invariant_client_request, cronies_term.
    intros. subst. simpl in *. repeat find_higher_order_rewrite.
    update_destruct; subst; rewrite_update; eauto.
    simpl in *. find_apply_lem_hyp handleClientRequest_spec.
    find_rewrite. eauto.
  Qed.
  (*   H : handleTimeout h' (snd (nwState net h')) = (out, d, l)
       In h0 (cronies (update_elections_data_timeout h' (nwState net h')) t)
   *)

  Lemma handleTimeout_spec :
    forall h st out st' l t h',
      handleTimeout h (snd st) = (out, st', l) ->
      In h' (cronies (update_elections_data_timeout h st) t) ->
      (currentTerm (snd st) <= currentTerm st' /\
       (In h' (cronies (fst st) t) \/
        t = currentTerm st')).
  Proof.
    intros.
    unfold handleTimeout, tryToBecomeLeader, update_elections_data_timeout in *.
    repeat (break_match; repeat find_inversion; simpl in *; auto);
      intuition;
      unfold handleTimeout, tryToBecomeLeader in *;
      repeat (break_match; repeat find_inversion; simpl in *; auto); congruence.
  Qed.

  Lemma cronies_term_timeout :
    refined_raft_net_invariant_timeout cronies_term.
  Proof.
    unfold refined_raft_net_invariant_timeout, cronies_term.
    intros. subst. simpl in *. repeat find_higher_order_rewrite.
    update_destruct; subst; rewrite_update; eauto.
    simpl in *.
    find_eapply_lem_hyp handleTimeout_spec; eauto. intuition.
    eapply le_trans; [|eauto]; eauto.
  Qed.

  Lemma doLeader_spec :
    forall st h os st' ms,
      doLeader st h = (os, st', ms) ->
      currentTerm st' = currentTerm st.
  Proof.
    intros. unfold doLeader in *.
    repeat break_match; repeat find_inversion; auto.
  Qed.

  Lemma cronies_term_do_leader :
    refined_raft_net_invariant_do_leader cronies_term.
  Proof.
    unfold refined_raft_net_invariant_do_leader, cronies_term.
    intros. subst. simpl in *. repeat find_higher_order_rewrite.
    update_destruct; subst; rewrite_update; eauto.
    simpl in *.
    find_apply_lem_hyp doLeader_spec.
    repeat find_rewrite.
    match goal with
      | H : nwState ?net ?h = (?g, ?st) |- _ =>
        replace g with (fst (nwState net h)) in *; [|rewrite H; auto];
        replace st with (snd (nwState net h)) in *; [|rewrite H; auto]
    end; eauto.
  Qed.

  Lemma doGenericServer_spec :
    forall st h os st' ms,
      doGenericServer h st = (os, st', ms) ->
      currentTerm st' = currentTerm st.
  Proof.
    intros. unfold doGenericServer in *.
    repeat break_match; repeat find_inversion; auto.
  Qed.

  Lemma cronies_term_do_generic_server :
    refined_raft_net_invariant_do_generic_server cronies_term.
  Proof.
    unfold refined_raft_net_invariant_do_generic_server, cronies_term.
    intros. subst. simpl in *. repeat find_higher_order_rewrite.
    update_destruct; subst; rewrite_update; eauto.
    simpl in *.
    find_apply_lem_hyp doGenericServer_spec.
    repeat find_rewrite.
    match goal with
      | H : nwState ?net ?h = (?g, ?st) |- _ =>
        replace g with (fst (nwState net h)) in *; [|rewrite H; auto];
        replace st with (snd (nwState net h)) in *; [|rewrite H; auto]
    end; eauto.
  Qed.

  Lemma handleAppendEntries_spec :
    forall h st t n pli plt es ci st' m,
      handleAppendEntries h st t n pli plt es ci = (st', m) ->
      currentTerm st <= currentTerm st'.
  Proof.
    intros.
    unfold handleAppendEntries, advanceCurrentTerm in *.
    repeat break_match; find_inversion; simpl in *;
    do_bool; auto.
  Qed.

  Lemma update_elections_data_appendEntries_spec :
    forall h st t n pli plt es ci st' e t',
      update_elections_data_appendEntries h st t n pli plt es ci = st' ->
      In e (cronies st' t') ->
      In e (cronies (fst st) t').
  Proof.
    intros.
    unfold update_elections_data_appendEntries in *.
    repeat break_match; repeat find_rewrite; subst; simpl in *; auto.
  Qed.

  Lemma cronies_term_append_entries :
    refined_raft_net_invariant_append_entries cronies_term.
  Proof.
    unfold refined_raft_net_invariant_append_entries, cronies_term.
    intros. subst. simpl in *. repeat find_higher_order_rewrite.
    update_destruct; subst; rewrite_update; eauto.
    simpl in *.
    find_apply_lem_hyp handleAppendEntries_spec.
    find_eapply_lem_hyp update_elections_data_appendEntries_spec; eauto.
    eapply le_trans; [|eauto]; eauto.
  Qed.

  Lemma handleAppendEntriesReply_spec :
    forall h st h' t es r st' ms,
      handleAppendEntriesReply h st h' t es r = (st', ms) ->
      currentTerm st <= currentTerm st'.
  Proof.
    intros.
    unfold handleAppendEntriesReply, advanceCurrentTerm in *.
    repeat break_match; try find_inversion; subst; simpl in *;
    do_bool; intuition.
  Qed.

  Lemma cronies_term_append_entries_reply :
    refined_raft_net_invariant_append_entries_reply cronies_term.
  Proof.
    unfold refined_raft_net_invariant_append_entries_reply, cronies_term.
    intros. subst. simpl in *. repeat find_higher_order_rewrite.
    update_destruct; subst; rewrite_update; eauto.
    simpl in *.
    find_apply_lem_hyp handleAppendEntriesReply_spec.
    eapply le_trans; [|eauto]; eauto.
  Qed.

  Lemma handleRequestVote_spec :
    forall h st t h' pli plt st' m,
      handleRequestVote h st t h' pli plt = (st', m) ->
      currentTerm st <= currentTerm st'.
  Proof.
    intros.
    unfold handleRequestVote, advanceCurrentTerm in *.
    repeat break_match; try find_inversion; subst; simpl in *;
    do_bool; intuition.
  Qed.

  Lemma update_elections_data_requestVote_spec :
    forall h st t h' pli plt st' t' e s,
      update_elections_data_requestVote h h' t pli plt s st = st' ->
      In e (cronies st' t') ->
      In e (cronies (fst st) t').
  Proof.
    intros.
    unfold update_elections_data_requestVote in *.
    repeat break_match; repeat find_rewrite; subst; simpl in *; auto.
  Qed.

  Lemma cronies_term_request_vote :
    refined_raft_net_invariant_request_vote cronies_term.
  Proof.
    unfold refined_raft_net_invariant_request_vote, cronies_term.
    intros. subst. simpl in *. repeat find_higher_order_rewrite.
    update_destruct; subst; rewrite_update; eauto.
    simpl in *.
    find_apply_lem_hyp handleRequestVote_spec.
    find_eapply_lem_hyp update_elections_data_requestVote_spec; eauto.
    eapply le_trans; [|eauto]; eauto.
  Qed.

  Lemma handleRequestVoteReply_spec :
    forall h st h' t v st',
      st' = handleRequestVoteReply h st h' t v ->
      currentTerm st' = currentTerm st \/
      (currentTerm st <= currentTerm st' /\
       type st' = Follower).
  Proof.
    intros.
    unfold handleRequestVoteReply, advanceCurrentTerm in *.
    repeat break_match; try find_inversion; subst; simpl in *; intuition;
    do_bool; intuition.
  Qed.

  Lemma cronies_term_request_vote_reply :
    refined_raft_net_invariant_request_vote_reply cronies_term.
  Proof.
    unfold refined_raft_net_invariant_request_vote_reply, cronies_term.
    intros. subst. simpl in *. repeat find_higher_order_rewrite.
    update_destruct; subst; rewrite_update; eauto.
    simpl in *.
    match goal with
      | H : forall _, st' _ = _ |- _ => clear H
    end.
    unfold update_elections_data_requestVoteReply in *.
    match goal with
      | |- context [handleRequestVoteReply ?h ?st ?h' ?t ?v] =>
        remember (handleRequestVoteReply h st h' t v) as new_state
    end.
    find_copy_apply_lem_hyp handleRequestVoteReply_spec.
    intuition.
    - unfold update_elections_data_requestVoteReply in *.
      break_match; simpl in *; repeat find_rewrite; eauto;
      break_match; eauto;
      subst; repeat find_reverse_rewrite; intuition.
    - unfold update_elections_data_requestVoteReply in *.
      break_match; simpl in *;
      try solve [subst; unfold raft_data in *; congruence].
      eapply le_trans; [|eauto]; eauto.
  Qed.

  Lemma cronies_term_init :
    refined_raft_net_invariant_init cronies_term.
  Proof.
    unfold refined_raft_net_invariant_init, cronies_term.
    intros. simpl in *. intuition.
  Qed.

  Lemma cronies_term_reboot :
    refined_raft_net_invariant_reboot cronies_term.
  Proof.
    unfold refined_raft_net_invariant_reboot, cronies_term, reboot.
    intros. simpl in *. repeat find_higher_order_rewrite.
    update_destruct; subst; rewrite_update; eauto.
    simpl in *.
     match goal with
      | H : nwState ?net ?h = (?g, ?st) |- _ =>
        replace g with (fst (nwState net h)) in *; [|rewrite H; auto];
        replace st with (snd (nwState net h)) in *; [|rewrite H; auto]
     end; eauto.
  Qed.

  Lemma cronies_term_state_same_packet_subset :
    refined_raft_net_invariant_state_same_packet_subset cronies_term.
  Proof.
    unfold refined_raft_net_invariant_state_same_packet_subset, cronies_term.
    intros.
    repeat find_reverse_higher_order_rewrite. eauto.
  Qed.

  Theorem cronies_term_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      cronies_term net.
  Proof.
    intros. apply refined_raft_net_invariant; auto.
    - apply cronies_term_init.
    - apply cronies_term_client_request.
    - apply cronies_term_timeout.
    - apply cronies_term_append_entries.
    - apply cronies_term_append_entries_reply.
    - apply cronies_term_request_vote.
    - apply cronies_term_request_vote_reply.
    - apply cronies_term_do_leader.
    - apply cronies_term_do_generic_server.
    - apply cronies_term_state_same_packet_subset.
    - apply cronies_term_reboot.
  Qed.

End CroniesTerm.


Declare ML Module "coq-paramcoq.plugin".

Ltac destruct_reflexivity :=
  intros ; repeat match goal with
    | [ x : _ |- _ = _ ] => destruct x; reflexivity; fail
  end.

Ltac destruct_construct x :=
    (destruct x; [ constructor 1 ]; auto; fail)
 || (destruct x; [ constructor 1 | constructor 2 ]; auto; fail)
 || (destruct x; [ constructor 1 | constructor 2 | constructor 3]; auto; fail).

Ltac unfold_cofix := intros; match goal with
 [ |- _ = ?folded ] =>
    let x := fresh "x" in
    let typ := type of folded in
    (match folded with _ _ => pattern folded | _ => pattern folded at 2 end);
    match goal with [ |- ?P ?x ] =>
    refine (let rebuild : typ -> typ := _ in
            let path : rebuild folded = folded := _ in
            eq_rect _ P _ folded path) end;
    [ intro x ; destruct_construct x; fail
    | destruct folded; reflexivity
    | reflexivity]; fail
end.

Ltac destruct_with_nat_arg_pattern x :=
  pattern x;
  match type of x with
   | ?I 0 => refine (let gen : forall m (q : I m),
     (match m return I m -> Type with
         0 => fun p => _ p
     | S n => fun _  => unit end q) := _ in gen 0 x)
   | ?I (S ?n) => refine (let gen : forall m (q : I m),
     (match m return I m -> Type with
         0 => fun _  => unit
     | S n => fun p => _ p end q) := _ in gen (S n) x)
  end; intros m q; destruct q.

Ltac destruct_reflexivity_with_nat_arg_pattern :=
  intros ; repeat match goal with
    | [ x : _ |- _ = _ ] => destruct_with_nat_arg_pattern x; reflexivity; fail
  end.

Axiom absurd : forall X, X.

Ltac admit_and_print :=
  intros; match goal with
  | [ |- _ = ?RHS ] => idtac "Warning: admiting an ogligation for" RHS
  | [ |- ?GOAL] => idtac "Warning: admiting an ogligation of goal" GOAL
  end; apply absurd.

Global Parametricity Tactic := ((destruct_reflexivity; fail)
                            || (unfold_cofix; fail)
                            || (destruct_reflexivity_with_nat_arg_pattern; fail)
                            || admit_and_print).

Require ProofIrrelevance. (* for opaque terms *)


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Translation from Mach to ARM. *)

Require Import Coqlib.
Require Import Errors.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Op.
Require Import Locations.
Require Import Mach.
Require Import Asm.

Open Local Scope string_scope.
Open Local Scope error_monad_scope.

(** Extracting integer or float registers. *)

Definition ireg_of (r: mreg) : res ireg :=
  match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgen.ireg_of") end.

Definition freg_of (r: mreg) : res freg :=
  match preg_of r with FR mr => OK mr | _ => Error(msg "Asmgen.freg_of") end.

(** Recognition of integer immediate arguments.
- For arithmetic operations, immediates are
  8-bit quantities zero-extended and rotated right by 0, 2, 4, ... 30 bits.
- For memory accesses of type [Mint32], immediate offsets are
  12-bit quantities plus a sign bit.
- For other memory accesses, immediate offsets are
  8-bit quantities plus a sign bit. *)

Fixpoint is_immed_arith_aux (n: nat) (x msk: int) {struct n}: bool :=
  match n with
  | Datatypes.O => false
  | Datatypes.S n' =>
      Int.eq (Int.and x (Int.not msk)) Int.zero ||
      is_immed_arith_aux n' x (Int.ror msk (Int.repr 2))
  end.

Definition is_immed_arith (x: int) : bool :=
  is_immed_arith_aux 16%nat x (Int.repr 255).

Definition is_immed_mem_word (x: int) : bool :=
  Int.lt x (Int.repr 4096) && Int.lt (Int.repr (-4096)) x.

Definition mk_immed_mem_word (x: int) : int :=
  Int.sign_ext 13 x.

Definition is_immed_mem_small (x: int) : bool :=
  Int.lt x (Int.repr 256) && Int.lt (Int.repr (-256)) x.

Definition mk_immed_mem_small (x: int) : int :=
  Int.sign_ext 9 x.

Definition is_immed_mem_float (x: int) : bool :=
  Int.eq (Int.and x (Int.repr 3)) Int.zero
  && Int.lt x (Int.repr 1024) && Int.lt (Int.repr (-1024)) x.

Definition mk_immed_mem_float (x: int) : int :=
  Int.and (Int.sign_ext 11 x) (Int.repr 4294967288).  (**r 0xfffffff8 *)

(** Decomposition of a 32-bit integer into a list of immediate arguments,
    whose sum or "or" or "xor" equals the integer. *)

Fixpoint decompose_int_rec (N: nat) (n p: int) : list int :=
  match N with
  | Datatypes.O =>
      if Int.eq n Int.zero then nil else n :: nil
  | Datatypes.S M =>
      if Int.eq (Int.and n (Int.shl (Int.repr 3) p)) Int.zero then
        decompose_int_rec M n (Int.add p (Int.repr 2))
      else
        let m := Int.shl (Int.repr 255) p in
        Int.and n m ::
        decompose_int_rec M (Int.and n (Int.not m)) (Int.add p (Int.repr 2))
  end.

Definition decompose_int (n: int) : list int :=
  match decompose_int_rec 12%nat n Int.zero with
  | nil => Int.zero :: nil
  | l   => l
  end.

Definition iterate_op (op1 op2: shift_op -> instruction) (l: list int) (k: code) :=
  match l with
  | nil =>
      op1 (SOimm Int.zero) :: k                 (**r should never happen *)
  | i :: l' =>
      op1 (SOimm i) :: map (fun i => op2 (SOimm i)) l' ++ k
  end.

(** Smart constructors for integer immediate arguments. *)

Definition loadimm (r: ireg) (n: int) (k: code) :=
  let d1 := decompose_int n in
  let d2 := decompose_int (Int.not n) in
  if NPeano.leb (List.length d1) (List.length d2)
  then iterate_op (Pmov r) (Porr r r) d1 k
  else iterate_op (Pmvn r) (Pbic r r) d2 k.

Definition addimm (r1 r2: ireg) (n: int) (k: code) :=
  let d1 := decompose_int n in
  let d2 := decompose_int (Int.neg n) in
  if NPeano.leb (List.length d1) (List.length d2)
  then iterate_op (Padd r1 r2) (Padd r1 r1) d1 k
  else iterate_op (Psub r1 r2) (Psub r1 r1) d2 k.

Definition andimm (r1 r2: ireg) (n: int) (k: code) :=
  if is_immed_arith n
  then Pand r1 r2 (SOimm n) :: k
  else iterate_op (Pbic r1 r2) (Pbic r1 r1) (decompose_int (Int.not n)) k.

Definition rsubimm (r1 r2: ireg) (n: int) (k: code) :=
  iterate_op (Prsb r1 r2) (Padd r1 r1) (decompose_int n) k.

Definition orimm  (r1 r2: ireg) (n: int) (k: code) :=
  iterate_op (Porr r1 r2) (Porr r1 r1) (decompose_int n) k.

Definition xorimm  (r1 r2: ireg) (n: int) (k: code) :=
  iterate_op (Peor r1 r2) (Peor r1 r1) (decompose_int n) k.

(** Translation of a shift immediate operation (type [Op.shift]) *)

Definition transl_shift (s: shift) (r: ireg) : shift_op :=
  match s with
  | Slsl n => SOlslimm r (s_amount n)
  | Slsr n => SOlsrimm r (s_amount n)
  | Sasr n => SOasrimm r (s_amount n)
  | Sror n => SOrorimm r (s_amount n)
  end.

(** Translation of a condition.  Prepends to [k] the instructions
  that evaluate the condition and leave its boolean result in one of
  the bits of the condition register.  The bit in question is
  determined by the [crbit_for_cond] function. *)

Definition transl_cond
              (cond: condition) (args: list mreg) (k: code) :=
  match cond, args with
  | Ccomp c, a1 :: a2 :: nil =>
      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pcmp r1(SOreg r2) :: k)
  | Ccompu c, a1 :: a2 :: nil =>
      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pcmp r1 (SOreg r2) :: k)
  | Ccompshift c s, a1 :: a2 :: nil =>
      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pcmp r1 (transl_shift s r2) :: k)
  | Ccompushift c s, a1 :: a2 :: nil =>
      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pcmp r1 (transl_shift s r2) :: k)
  | Ccompimm c n, a1 :: nil =>
      do r1 <- ireg_of a1;
      OK (if is_immed_arith n then
            Pcmp r1 (SOimm n) :: k
          else
            loadimm IR14 n (Pcmp r1 (SOreg IR14) :: k))
  | Ccompuimm c n, a1 :: nil =>
      do r1 <- ireg_of a1;
      OK (if is_immed_arith n then
            Pcmp r1 (SOimm n) :: k
          else
            loadimm IR14 n (Pcmp r1 (SOreg IR14) :: k))
  | Ccompf cmp, a1 :: a2 :: nil =>
      do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfcmpd r1 r2 :: k)
  | Cnotcompf cmp, a1 :: a2 :: nil =>
      do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfcmpd r1 r2 :: k)
  | Ccompfzero cmp, a1 :: nil =>
      do r1 <- freg_of a1;
      OK (Pfcmpzd r1 :: k)
  | Cnotcompfzero cmp, a1 :: nil =>
      do r1 <- freg_of a1;
      OK (Pfcmpzd r1 :: k)
  | _, _ =>
      Error(msg "Asmgen.transl_cond")
  end.

Definition crbit_for_signed_cmp (cmp: comparison) :=
  match cmp with
  | Ceq => CReq
  | Cne => CRne
  | Clt => CRlt
  | Cle => CRle
  | Cgt => CRgt
  | Cge => CRge
  end.

Definition crbit_for_unsigned_cmp (cmp: comparison) :=
  match cmp with
  | Ceq => CReq
  | Cne => CRne
  | Clt => CRlo
  | Cle => CRls
  | Cgt => CRhi
  | Cge => CRhs
  end.

Definition crbit_for_float_cmp (cmp: comparison) :=
  match cmp with
  | Ceq => CReq
  | Cne => CRne
  | Clt => CRmi
  | Cle => CRls
  | Cgt => CRgt
  | Cge => CRge
  end.

Definition crbit_for_float_not_cmp (cmp: comparison) :=
  match cmp with
  | Ceq => CRne
  | Cne => CReq
  | Clt => CRpl
  | Cle => CRhi
  | Cgt => CRle
  | Cge => CRlt
  end.

Definition crbit_for_cond (cond: condition) :=
  match cond with
  | Ccomp cmp => crbit_for_signed_cmp cmp
  | Ccompu cmp => crbit_for_unsigned_cmp cmp
  | Ccompshift cmp s => crbit_for_signed_cmp cmp
  | Ccompushift cmp s => crbit_for_unsigned_cmp cmp
  | Ccompimm cmp n => crbit_for_signed_cmp cmp
  | Ccompuimm cmp n => crbit_for_unsigned_cmp cmp
  | Ccompf cmp => crbit_for_float_cmp cmp
  | Cnotcompf cmp => crbit_for_float_not_cmp cmp
  | Ccompfzero cmp => crbit_for_float_cmp cmp
  | Cnotcompfzero cmp => crbit_for_float_not_cmp cmp
  end.

(** Translation of the arithmetic operation [r <- op(args)].
  The corresponding instructions are prepended to [k]. *)

Definition transl_op
              (op: operation) (args: list mreg) (res: mreg) (k: code) :=
  match op, args with
  | Omove, a1 :: nil =>
      match preg_of res, preg_of a1 with
      | IR r, IR a => OK (Pmov r (SOreg a) :: k)
      | FR r, FR a => OK (Pfcpyd r a :: k)
      |  _  ,  _   => Error(msg "Asmgen.Omove")
      end
  | Ointconst n, nil =>
      do r <- ireg_of res;
      OK (loadimm r n k)
  | Ofloatconst f, nil =>
      do r <- freg_of res;
      OK (Pflid r f :: k)
  | Oaddrsymbol s ofs, nil =>
      do r <- ireg_of res;
      OK (Ploadsymbol r s ofs :: k)
  | Oaddrstack n, nil =>
      do r <- ireg_of res;
      OK (addimm r IR13 n k)
  | Oadd, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Padd r r1 (SOreg r2) :: k)
  | Oaddshift s, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Padd r r1 (transl_shift s r2) :: k)
  | Oaddimm n, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (addimm r r1 n k)
  | Osub, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Psub r r1 (SOreg r2) :: k)
  | Osubshift s, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Psub r r1 (transl_shift s r2) :: k)
  | Orsubshift s, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Prsb r r1 (transl_shift s r2) :: k)
  | Orsubimm n, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (rsubimm r r1 n k)
  | Omul, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (if negb (ireg_eq r r1) then Pmul r r1 r2 :: k
          else if negb (ireg_eq r r2) then Pmul r r2 r1 :: k
          else Pmul IR14 r1 r2 :: Pmov r (SOreg IR14) :: k)
  | Omla, a1 :: a2 :: a3 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      do r2 <- ireg_of a2; do r3 <- ireg_of a3;
      OK (if negb (ireg_eq r r1) then Pmla r r1 r2 r3 :: k
          else if negb (ireg_eq r r2) then Pmla r r2 r1 r3 :: k
          else Pmla IR14 r1 r2 r3 :: Pmov r (SOreg IR14) :: k)
  | Odiv, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Psdiv r r1 r2 :: k)
  | Odivu, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pudiv r r1 r2 :: k)
  | Oand, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pand r r1 (SOreg r2) :: k)
  | Oandshift s, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pand r r1 (transl_shift s r2) :: k)
  | Oandimm n, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (andimm r r1 n k)
  | Oor, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Porr r r1 (SOreg r2) :: k)
  | Oorshift s, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Porr r r1 (transl_shift s r2) :: k)
  | Oorimm n, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (orimm r r1 n k)
  | Oxor, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Peor r r1 (SOreg r2) :: k)
  | Oxorshift s, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Peor r r1 (transl_shift s r2) :: k)
  | Oxorimm n, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (xorimm r r1 n k)
  | Obic, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pbic r r1 (SOreg r2) :: k)
  | Obicshift s, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pbic r r1 (transl_shift s r2) :: k)
  | Onot, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (Pmvn r (SOreg r1) :: k)
  | Onotshift s, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (Pmvn r (transl_shift s r1) :: k)
  | Oshl, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pmov r (SOlslreg r1 r2) :: k)
  | Oshr, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pmov r (SOasrreg r1 r2) :: k)
  | Oshru, a1 :: a2 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pmov r (SOlsrreg r1 r2) :: k)
  | Oshift s, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (Pmov r (transl_shift s r1) :: k)
  | Oshrximm n, a1 :: nil =>
      do r <- ireg_of res; do r1 <- ireg_of a1;
      OK (Pcmp r1 (SOimm Int.zero) ::
          addimm IR14 r1 (Int.sub (Int.shl Int.one n) Int.one)
             (Pmovc CRge IR14 (SOreg r1) ::
              Pmov r (SOasrimm IR14 n) :: k))
  | Onegf, a1 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1;
      OK (Pfnegd r r1 :: k)
  | Oabsf, a1 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1;
      OK (Pfabsd r r1 :: k)
  | Oaddf, a1 :: a2 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfaddd r r1 r2 :: k)
  | Osubf, a1 :: a2 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfsubd r r1 r2 :: k)
  | Omulf, a1 :: a2 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfmuld r r1 r2 :: k)
  | Odivf, a1 :: a2 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfdivd r r1 r2 :: k)
  | Osingleoffloat, a1 :: nil =>
      do r <- freg_of res; do r1 <- freg_of a1;
      OK (Pfcvtsd r r1 :: k)
  | Ointoffloat, a1 :: nil =>
      do r <- ireg_of res; do r1 <- freg_of a1;
      OK (Pftosizd r r1 :: k)
  | Ointuoffloat, a1 :: nil =>
      do r <- ireg_of res; do r1 <- freg_of a1;
      OK (Pftouizd r r1 :: k)
  | Ofloatofint, a1 :: nil =>
      do r <- freg_of res; do r1 <- ireg_of a1;
      OK (Pfsitod r r1 :: k)
  | Ofloatofintu, a1 :: nil =>
      do r <- freg_of res; do r1 <- ireg_of a1;
      OK (Pfuitod r r1 :: k)
  | Ocmp cmp, _ =>
      do r <- ireg_of res;
      transl_cond cmp args
        (Pmov r (SOimm Int.zero) ::
         Pmovc (crbit_for_cond cmp) r (SOimm Int.one) ::
         k)
  | _, _ =>
      Error(msg "Asmgen.transl_op")
  end.

(** Accessing data in the stack frame. *)

Definition indexed_memory_access
    (mk_instr: ireg -> int -> instruction)
    (mk_immed: int -> int)
    (base: ireg) (n: int) (k: code) :=
  let n1 := mk_immed n in
  if Int.eq n n1
  then mk_instr base n :: k
  else addimm IR14 base (Int.sub n n1) (mk_instr IR14 n1 :: k).

Definition loadind_int (base: ireg) (ofs: int) (dst: ireg) (k: code) :=
  indexed_memory_access (fun base n => Pldr dst base (SAimm n)) mk_immed_mem_word base ofs k.

Definition loadind (base: ireg) (ofs: int) (ty: typ) (dst: mreg) (k: code) :=
  match ty with
  | Tint =>
      do r <- ireg_of dst; OK (loadind_int base ofs r k)
  | Tfloat =>
      do r <- freg_of dst;
      OK (indexed_memory_access (Pfldd r) mk_immed_mem_float base ofs k)
  | Tsingle =>
      do r <- freg_of dst;
      OK (indexed_memory_access (Pflds r) mk_immed_mem_float base ofs k)
  | Tlong =>
      Error (msg "Asmgen.loadind")
  end.

Definition storeind (src: mreg) (base: ireg) (ofs: int) (ty: typ) (k: code) :=
  match ty with
  | Tint =>
      do r <- ireg_of src;
      OK (indexed_memory_access (fun base n => Pstr r base (SAimm n)) mk_immed_mem_word base ofs k)
  | Tfloat =>
      do r <- freg_of src;
      OK (indexed_memory_access (Pfstd r) mk_immed_mem_float base ofs k)
  | Tsingle =>
      do r <- freg_of src;
      OK (indexed_memory_access (Pfsts r) mk_immed_mem_float base ofs k)
  | Tlong =>
      Error (msg "Asmgen.storeind")
  end.

(** Translation of memory accesses *)

Definition transl_shift_addr (s: shift) (r: ireg) : shift_addr :=
  match s with
  | Slsl n => SAlsl r (s_amount n)
  | Slsr n => SAlsr r (s_amount n)
  | Sasr n => SAasr r (s_amount n)
  | Sror n => SAror r (s_amount n)
  end.

Definition transl_memory_access
     (mk_instr_imm: ireg -> int -> instruction)
     (mk_instr_gen: option (ireg -> shift_addr -> instruction))
     (mk_immed: int -> int)
     (addr: addressing) (args: list mreg) (k: code) :=
  match addr, args with
  | Aindexed n, a1 :: nil =>
      do r1 <- ireg_of a1;
      OK (indexed_memory_access mk_instr_imm mk_immed r1 n k)
  | Aindexed2, a1 :: a2 :: nil =>
      match mk_instr_gen with
      | Some f =>
          do r1 <- ireg_of a1; do r2 <- ireg_of a2;
          OK (f r1 (SAreg r2) :: k)
      | None =>
          Error (msg "Asmgen.Aindexed2")
      end
  | Aindexed2shift s, a1 :: a2 :: nil =>
      match mk_instr_gen with
      | Some f =>
          do r1 <- ireg_of a1; do r2 <- ireg_of a2;
          OK (f r1 (transl_shift_addr s r2) :: k)
      | None =>
          Error (msg "Asmgen.Aindexed2shift")
      end
  | Ainstack n, nil =>
      OK (indexed_memory_access mk_instr_imm mk_immed IR13 n k)
  | _, _ =>
      Error(msg "Asmgen.transl_memory_access")
  end.

Definition transl_memory_access_int
     (mk_instr: ireg -> ireg -> shift_addr -> instruction)
     (mk_immed: int -> int)
     (dst: mreg) (addr: addressing) (args: list mreg) (k: code) :=
  do rd <- ireg_of dst;
  transl_memory_access
    (fun r n => mk_instr rd r (SAimm n))
    (Some (mk_instr rd))
    mk_immed addr args k.

Definition transl_memory_access_float
     (mk_instr: freg -> ireg -> int -> instruction)
     (mk_immed: int -> int)
     (dst: mreg) (addr: addressing) (args: list mreg) (k: code) :=
  do rd <- freg_of dst;
  transl_memory_access
    (mk_instr rd)
    None
    mk_immed addr args k.

Definition transl_load (chunk: memory_chunk) (addr: addressing)
                       (args: list mreg) (dst: mreg) (k: code) :=
  match chunk with
  | Mint8signed =>
      transl_memory_access_int Pldrsb mk_immed_mem_small dst addr args k
  | Mint8unsigned =>
      transl_memory_access_int Pldrb mk_immed_mem_word dst addr args k
  | Mint16signed =>
      transl_memory_access_int Pldrsh mk_immed_mem_small dst addr args k
  | Mint16unsigned =>
      transl_memory_access_int Pldrh mk_immed_mem_small dst addr args k
  | Mint32 =>
      transl_memory_access_int Pldr mk_immed_mem_word dst addr args k
  | Mfloat32 =>
      transl_memory_access_float Pflds mk_immed_mem_float dst addr args k
  | Mfloat64 | Mfloat64al32 =>
      transl_memory_access_float Pfldd mk_immed_mem_float dst addr args k
  | Mint64 =>
      Error (msg "Asmgen.transl_load")
  end.

Definition transl_store (chunk: memory_chunk) (addr: addressing)
                       (args: list mreg) (src: mreg) (k: code) :=
  match chunk with
  | Mint8signed =>
      transl_memory_access_int Pstrb mk_immed_mem_small src addr args k
  | Mint8unsigned =>
      transl_memory_access_int Pstrb mk_immed_mem_word src addr args k
  | Mint16signed =>
      transl_memory_access_int Pstrh mk_immed_mem_small src addr args k
  | Mint16unsigned =>
      transl_memory_access_int Pstrh mk_immed_mem_small src addr args k
  | Mint32 =>
      transl_memory_access_int Pstr mk_immed_mem_word src addr args k
  | Mfloat32 =>
      transl_memory_access_float Pfsts mk_immed_mem_float src addr args k
  | Mfloat64 | Mfloat64al32 =>
      transl_memory_access_float Pfstd mk_immed_mem_float src addr args k
  | Mint64 =>
      Error (msg "Asmgen.transl_store")
  end.

(** Translation of arguments to annotations *)

Definition transl_annot_param (p: Mach.annot_param) : Asm.annot_param :=
  match p with
  | Mach.APreg r => APreg (preg_of r)
  | Mach.APstack chunk ofs => APstack chunk ofs
  end.

(** Translation of a Mach instruction. *)

Definition transl_instr (f: Mach.function) (i: Mach.instruction)
                        (r12_is_parent: bool) (k: code) :=
  match i with
  | Mgetstack ofs ty dst =>
      loadind IR13 ofs ty dst k
  | Msetstack src ofs ty =>
      storeind src IR13 ofs ty k
  | Mgetparam ofs ty dst =>
      do c <- loadind IR12 ofs ty dst k;
      OK (if r12_is_parent
          then c
          else loadind_int IR13 f.(fn_link_ofs) IR12 c)
  | Mop op args res =>
      transl_op op args res k
  | Mload chunk addr args dst =>
      transl_load chunk addr args dst k
  | Mstore chunk addr args src =>
      transl_store chunk addr args src k
  | Mcall sig (inl arg) =>
      do r <- ireg_of arg; OK (Pblreg r sig :: k)
  | Mcall sig (inr symb) =>
      OK (Pblsymb symb sig :: k)
  | Mtailcall sig (inl arg) =>
      do r <- ireg_of arg;
      OK (loadind_int IR13 f.(fn_retaddr_ofs) IR14
           (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: Pbreg r sig :: k))
  | Mtailcall sig (inr symb) =>
      OK (loadind_int IR13 f.(fn_retaddr_ofs) IR14
           (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: Pbsymb symb sig :: k))
  | Mbuiltin ef args res =>
      OK (Pbuiltin ef (map preg_of args) (map preg_of res) :: k)
  | Mannot ef args =>
      OK (Pannot ef (map transl_annot_param args) :: k)
  | Mlabel lbl =>
      OK (Plabel lbl :: k)
  | Mgoto lbl =>
      OK (Pb lbl :: k)
  | Mcond cond args lbl =>
      transl_cond cond args (Pbc (crbit_for_cond cond) lbl :: k)
  | Mjumptable arg tbl =>
      do r <- ireg_of arg;
      OK (Pbtbl r tbl :: k)
  | Mreturn =>
      OK (loadind_int IR13 f.(fn_retaddr_ofs) IR14
            (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) ::
             Pbreg IR14 f.(Mach.fn_sig) :: k))
  end.

(** Translation of a code sequence *)

Definition it1_is_parent (before: bool) (i: Mach.instruction) : bool :=
  match i with
  | Msetstack src ofs ty => before
  | Mgetparam ofs ty dst => negb (mreg_eq dst R12)
  | Mop Omove args res => before && negb (mreg_eq res R12)
  | _ => false
  end.

(** This is the naive definition that we no longer use because it
  is not tail-recursive.  It is kept as specification. *)

Fixpoint transl_code (f: Mach.function) (il: list Mach.instruction) (it1p: bool) :=
  match il with
  | nil => OK nil
  | i1 :: il' =>
      do k <- transl_code f il' (it1_is_parent it1p i1);
      transl_instr f i1 it1p k
  end.

(** This is an equivalent definition in continuation-passing style
  that runs in constant stack space. *)

Fixpoint transl_code_rec (f: Mach.function) (il: list Mach.instruction)
                         (it1p: bool) (k: code -> res code) :=
  match il with
  | nil => k nil
  | i1 :: il' =>
      transl_code_rec f il' (it1_is_parent it1p i1)
        (fun c1 => do c2 <- transl_instr f i1 it1p c1; k c2)
  end.

Definition transl_code' (f: Mach.function) (il: list Mach.instruction) (it1p: bool) :=
  transl_code_rec f il it1p (fun c => OK c).

(** Translation of a whole function.  Note that we must check
  that the generated code contains less than [2^32] instructions,
  otherwise the offset part of the [PC] code pointer could wrap
  around, leading to incorrect executions. *)

Definition transl_function (f: Mach.function) :=
  do c <- transl_code f f.(Mach.fn_code) true;
  OK (mkfunction f.(Mach.fn_sig)
        (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::
         Pstr IR14 IR13 (SAimm f.(fn_retaddr_ofs)) :: c)).

Definition transf_function (f: Mach.function) : res Asm.function :=
  do tf <- transl_function f;
  if zlt Int.max_unsigned (list_length_z tf.(fn_code))
  then Error (msg "code size exceeded")
  else OK tf.

Definition transf_fundef (f: Mach.fundef) : res Asm.fundef :=
  transf_partial_fundef transf_function f.

Definition transf_program (p: Mach.program) : res Asm.program :=
  transform_partial_program transf_fundef p.