105 files changed, 10302 insertions, 3910 deletions

diff --git a/Makefile b/Makefile
index 75f475ef..03f54744 100644
--- a/Makefile
+++ b/Makefile
@@ -95,7 +95,9 @@ BACKEND=\
   Debugvar.v Debugvarproof.v \
   Mach.v \
   Bounds.v Stacklayout.v Stacking.v Stackingproof.v \
-  Asm.v Asmgen.v Asmgenproof0.v Asmgenproof1.v Asmgenproof.v
+  Machblock.v Machblockgen.v Machblockgenproof.v \
+  Asmblock.v Asmblockgen.v Asmblockgenproof0.v Asmblockgenproof1.v Asmblockgenproof.v \
+  Asm.v Asmgen.v Asmgenproof.v
 
 # C front-end modules (in cfrontend/)
 
@@ -118,7 +120,7 @@ PARSER=Cabs.v Parser.v
 
 # Putting everything together (in driver/)
 
-DRIVER=Compopts.v Compiler.v Complements.v
+DRIVER=Compopts.v Compiler.v Complements.v ForwardSimulationBlock.v
 
 # All source files
 
diff --git a/backend/Asmexpandaux.ml b/backend/Asmexpandaux.ml
index 23fef3f2..62c4a702 100644
--- a/backend/Asmexpandaux.ml
+++ b/backend/Asmexpandaux.ml
@@ -26,7 +26,9 @@ let emit i = current_code := i :: !current_code
 
 (* Generation of fresh labels *)
 
-let dummy_function = { fn_code = []; fn_sig = signature_main }
+(** dummy_funtion is now defined in Asm.v *)
+(* let dummy_function = { fn_code = []; fn_sig = signature_main } *)
+
 let current_function = ref dummy_function
 let next_label = ref (None: label option)
 
@@ -39,7 +41,7 @@ let new_label () =
         List.fold_left
           (fun next instr ->
             match instr with
-            | PExpand (Plabel l) -> if P.lt l next then next else P.succ l
+            | Plabel l -> if P.lt l next then next else P.succ l
             | _ -> next)
           P.one (!current_function).fn_code
   in
@@ -100,17 +102,17 @@ let expand_debug id sp preg simple l =
   let get_lbl = function
     | None ->
         let lbl = new_label () in
-        emit (PExpand (Plabel lbl));
+        emit (Plabel lbl);
         lbl
     | Some lbl -> lbl in
   let rec  aux lbl scopes = function
     | [] -> ()
-    | (PExpand (Pbuiltin(EF_debug (kind,txt,_x),args,_) as i))::rest ->
+    | (Pbuiltin(EF_debug (kind,txt,_x),args,_) as i)::rest ->
         let kind = (P.to_int kind) in
         begin
           match kind with
           | 1->
-              emit (PExpand i);aux lbl scopes rest
+              emit i; aux lbl scopes rest
           | 2 ->
               aux  lbl scopes rest
           | 3 ->
@@ -142,11 +144,11 @@ let expand_debug id sp preg simple l =
           | _ ->
               aux None scopes rest
         end
-    | (PExpand (Plabel lbl))::rest -> simple (PExpand (Plabel lbl)); aux (Some lbl) scopes rest
+    | (Plabel lbl)::rest -> simple (Plabel lbl); aux (Some lbl) scopes rest
     | i::rest -> simple i; aux None scopes rest in
   (* We need to move all closing debug annotations before the last real statement *)
   let rec move_debug acc bcc = function
-    | (PExpand (Pbuiltin(EF_debug (kind,_,_),_,_)) as i)::rest ->
+    | (Pbuiltin(EF_debug (kind,_,_),_,_)) as i::rest ->
         let kind = (P.to_int kind) in
         if kind = 1 then
           move_debug acc (i::bcc) rest (* Do not move debug line *)
diff --git a/configure b/configure
index 1b5b933d..503a899b 100755
--- a/configure
+++ b/configure
@@ -414,16 +414,17 @@ fi
 if test "$arch" = "mppa_k1c"; then
   #model_options="-march=rv64imafd -mabi=lp64d"
   # FIXME - maybe later add it for NodeOS & cie
-  model_options=-m64
+  #model_options=-m64
+  model_options=
   abi="standard"
-  casm="${toolprefix}gcc"
+  casm="k1-mbr-gcc"
   casm_options="$model_options -c"
-  cc="${toolprefix}gcc $model_options"
-  clinker="${toolprefix}gcc"
+  cc="k1-mbr-gcc $model_options"
+  clinker="k1-mbr-gcc"
   bindir="$HOME/.usr/bin"
   libdir="$HOME/.usr/lib"
   clinker_options="$model_options -L$libdir -Wl,-rpath=$libdir"
-  cprepro="${toolprefix}gcc"
+  cprepro="k1-mbr-gcc"
   cprepro_options="$model_options -std=c99 -U__GNUC__ -E"
   libmath="-lm"
   system="linux"
diff --git a/driver/Compiler.v b/driver/Compiler.v
index 75247f71..1cb5bd36 100644
--- a/driver/Compiler.v
+++ b/driver/Compiler.v
@@ -404,7 +404,7 @@ Ltac DestructM :=
   eapply compose_forward_simulations.
     eapply match_if_simulation. eassumption. exact Debugvarproof.transf_program_correct.
   eapply compose_forward_simulations.
-    eapply Stackingproof.transf_program_correct with (return_address_offset := Asmgenproof0.return_address_offset).
+    eapply Stackingproof.transf_program_correct with (return_address_offset := Asmgenproof.return_address_offset).
     exact Asmgenproof.return_address_exists.
     eassumption.
   eapply Asmgenproof.transf_program_correct; eassumption.
diff --git a/driver/ForwardSimulationBlock.v b/driver/ForwardSimulationBlock.v
new file mode 100644
index 00000000..dc8beb29
--- /dev/null
+++ b/driver/ForwardSimulationBlock.v
@@ -0,0 +1,322 @@
+(***
+
+Auxiliary lemmas on starN and forward_simulation 
+in order to prove the forward simulation of Mach -> Machblock. 
+
+***)
+
+Require Import Relations.
+Require Import Wellfounded.
+Require Import Coqlib.
+Require Import Events.
+Require Import Globalenvs.
+Require Import Smallstep.
+
+
+Local Open Scope nat_scope.
+
+
+(** Auxiliary lemma on starN *)
+Section starN_lemma.
+
+Variable L: semantics.
+
+Local Hint Resolve starN_refl starN_step Eapp_assoc.
+
+Lemma starN_split n s t s':
+  starN (step L) (globalenv L) n s t s' ->
+  forall m k, n=m+k ->
+  exists (t1 t2:trace) s0, starN (step L) (globalenv L) m s t1 s0 /\ starN (step L) (globalenv L) k s0 t2 s' /\ t=t1**t2.
+Proof.
+  induction 1; simpl.
+  + intros m k H; assert (X: m=0); try omega.
+    assert (X0: k=0); try omega.
+    subst; repeat (eapply ex_intro); intuition eauto.
+  + intros m; destruct m as [| m']; simpl.
+    - intros k H2; subst; repeat (eapply ex_intro); intuition eauto.
+    - intros k H2. inversion H2.
+      exploit (IHstarN m' k); eauto. intro.
+      destruct H3 as (t5 & t6 & s0 & H5 & H6 & H7).
+      repeat (eapply ex_intro).
+      instantiate (1 := t6); instantiate (1 := t1 ** t5); instantiate (1 := s0).
+      intuition eauto. subst. auto.
+Qed.
+
+Lemma starN_tailstep n s t1 s': 
+  starN (step L) (globalenv L) n s t1 s' ->
+  forall (t t2:trace) s'',
+     Step L s' t2 s'' -> t = t1 ** t2 -> starN (step L) (globalenv L) (S n) s t s''.
+Proof.
+  induction 1; simpl. 
+  + intros t t1 s0; autorewrite with trace_rewrite.
+    intros; subst; eapply starN_step; eauto.
+    autorewrite with trace_rewrite; auto.
+  + intros. eapply  starN_step; eauto.
+    intros; subst; autorewrite with trace_rewrite; auto.
+Qed.
+
+End starN_lemma.
+
+
+
+(** General scheme from a "match_states" relation *)
+
+Section ForwardSimuBlock_REL.
+
+Variable L1 L2: semantics.
+
+
+(** Hypothèses de la preuve *)
+
+Variable dist_end_block: state L1 -> nat.
+
+Hypothesis simu_mid_block:
+  forall s1 t s1', Step L1 s1 t s1' -> (dist_end_block s1)<>0 -> t = E0 /\ dist_end_block s1=S (dist_end_block s1').
+
+Hypothesis public_preserved:
+  forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id.
+
+Variable match_states: state L1 -> state L2 -> Prop.
+
+Hypothesis match_initial_states:
+  forall s1, initial_state L1 s1 -> exists s2, match_states s1 s2 /\ initial_state L2 s2.
+
+Hypothesis match_final_states:
+  forall s1 s2 r, final_state L1 s1 r -> match_states s1 s2 -> final_state L2 s2 r.
+
+Hypothesis final_states_end_block:
+  forall s1 t s1' r, Step L1 s1 t s1' -> final_state L1 s1' r -> dist_end_block s1 = 0.
+
+Hypothesis simu_end_block:
+  forall s1 t s1' s2, starN (step L1) (globalenv L1) (S (dist_end_block s1)) s1 t s1' -> match_states s1 s2 -> exists s2', Step L2 s2 t s2' /\ match_states s1' s2'.
+
+
+(** Introduction d'une sémantique par bloc sur L1 appelée "memoL1" *)
+
+Local Hint Resolve starN_refl starN_step.
+
+Definition follows_in_block (head current: state L1): Prop :=
+  dist_end_block head >= dist_end_block current 
+  /\ starN (step L1) (globalenv L1) (minus (dist_end_block head) (dist_end_block current)) head E0 current. 
+
+Lemma follows_in_block_step (head previous next: state L1):
+  forall t, follows_in_block head previous -> Step L1 previous t next -> (dist_end_block previous)<>0 -> follows_in_block head next.
+Proof.
+  intros t [H1 H2] H3 H4.
+  destruct (simu_mid_block _ _ _ H3 H4) as [H5 H6]; subst. 
+  constructor 1.
+  + omega.
+  + cutrewrite (dist_end_block head - dist_end_block next = S (dist_end_block head - dist_end_block previous)).
+    - eapply starN_tailstep; eauto.
+    - omega.
+Qed.
+
+Lemma follows_in_block_init (head current: state L1):
+  forall t, Step L1 head t current -> (dist_end_block head)<>0 -> follows_in_block head current.
+Proof.
+  intros t H3 H4.
+  destruct (simu_mid_block _ _ _ H3 H4) as [H5 H6]; subst. 
+  constructor 1.
+  + omega.
+  + cutrewrite (dist_end_block head - dist_end_block current = 1).
+    - eapply starN_tailstep; eauto.
+    - omega.
+Qed.
+
+
+Record memostate := {
+    real: state L1; 
+    memorized: option (state L1);
+    memo_star: forall head, memorized = Some head -> follows_in_block head real;
+    memo_final: forall r, final_state L1 real r -> memorized = None
+}.
+
+Definition head (s: memostate): state L1 :=
+    match memorized s with
+    | None => real s
+    | Some s' => s'
+    end.
+
+Lemma head_followed (s: memostate): follows_in_block (head s) (real s).
+Proof.
+  destruct s as [rs ms Hs]. simpl.
+  destruct ms as [ms|]; unfold head; simpl; auto.
+  constructor 1.
+  omega.
+  cutrewrite ((dist_end_block rs - dist_end_block rs)%nat=O).
+  + apply starN_refl; auto.
+  + omega.
+Qed.
+
+Inductive is_well_memorized (s s': memostate): Prop :=
+  | StartBloc:
+    dist_end_block (real s) <> O  ->
+    memorized s = None ->
+    memorized s' = Some (real s) ->
+    is_well_memorized s s'
+  | MidBloc:
+    dist_end_block (real s) <> O ->
+    memorized s <> None ->
+    memorized s' = memorized s ->
+    is_well_memorized s s'
+  | ExitBloc:
+    dist_end_block (real s) = O ->
+    memorized s' = None ->
+    is_well_memorized s s'.
+
+Local Hint Resolve StartBloc MidBloc ExitBloc.
+
+Definition memoL1 := {| 
+  state := memostate;
+  genvtype := genvtype L1;
+  step := fun ge s t s' => 
+    step L1 ge (real s) t (real s') 
+    /\ is_well_memorized s s' ;
+  initial_state := fun s => initial_state L1 (real s) /\ memorized s = None;
+  final_state := fun s r => final_state L1 (real s) r;
+  globalenv:= globalenv L1;
+  symbolenv:= symbolenv L1
+|}.
+
+
+(** Preuve des 2 forward simulations: L1 -> memoL1  et  memoL1 -> L2 *)
+
+Lemma discr_dist_end s:
+  {dist_end_block s = O} + {dist_end_block s <> O}.
+Proof.
+  destruct (dist_end_block s); simpl; intuition.
+Qed.
+
+Lemma memo_simulation_step:
+  forall s1 t s1', Step L1 s1 t s1' ->
+  forall s2, s1 = (real s2) -> exists s2', Step memoL1 s2 t s2' /\ s1' = (real s2').
+Proof.
+  intros s1 t s1' H1 [rs2 ms2 Hmoi] H2. simpl in H2; subst.
+  destruct (discr_dist_end rs2) as [H3 | H3].
+  + refine (ex_intro _ {|real:=s1'; memorized:=None |} _); simpl.
+    intuition.
+  + destruct ms2 as [s|].
+    - refine (ex_intro _ {|real:=s1'; memorized:=Some s |} _); simpl.
+      intuition.
+    - refine (ex_intro _ {|real:=s1'; memorized:=Some rs2 |} _); simpl.
+      intuition.
+  Unshelve.
+  * intros; discriminate.
+  * intros; auto.
+  * intros head X; injection X; clear X; intros; subst.
+    eapply follows_in_block_step; eauto.
+  * intros r X; erewrite final_states_end_block in H3; intuition eauto.
+  * intros head X; injection X; clear X; intros; subst.
+    eapply follows_in_block_init; eauto.
+  * intros r X; erewrite final_states_end_block in H3; intuition eauto.
+Qed.
+
+Lemma forward_memo_simulation_1: forward_simulation L1 memoL1.
+Proof.
+  apply forward_simulation_step with (match_states:=fun s1 s2 => s1 = (real s2)); auto.
+  + intros s1 H; eapply ex_intro with (x:={|real:=s1; memorized:=None |}); simpl.
+    intuition.
+  + intros; subst; auto.
+  + intros; exploit memo_simulation_step; eauto.
+  Unshelve.
+  * intros; discriminate.
+  * auto.
+Qed.
+
+Lemma forward_memo_simulation_2: forward_simulation memoL1 L2.
+Proof.
+  unfold memoL1; simpl.
+  apply forward_simulation_opt with (measure:=fun s => dist_end_block (real s)) (match_states:=fun s1 s2 => match_states (head s1) s2); simpl; auto.
+  + intros s1 [H0 H1]; destruct (match_initial_states (real s1) H0).
+    unfold head; rewrite H1.
+    intuition eauto.
+  + intros s1 s2 r X H0;  unfold head in X. 
+    erewrite memo_final in X; eauto.
+  + intros s1 t s1' [H1 H2] s2 H; subst.
+    destruct H2 as [ H0 H2 H3 | H0 H2 H3 | H0 H2].
+    - (* StartBloc *)
+      constructor 2. destruct (simu_mid_block (real s1) t (real s1')) as [H5 H4]; auto.
+      unfold head in * |- *. rewrite H2 in H. rewrite H3. rewrite H4. intuition.
+    - (* MidBloc *)
+      constructor 2. destruct (simu_mid_block (real s1) t (real s1')) as [H5 H4]; auto.
+      unfold head in * |- *. rewrite H3. rewrite H4. intuition.
+      destruct (memorized s1); simpl; auto. tauto.
+    - (* EndBloc *)
+      constructor 1.
+      destruct (simu_end_block (head s1) t (real s1') s2) as (s2' & H3 & H4); auto.
+      * destruct (head_followed s1) as [H4 H3].
+        cutrewrite (dist_end_block (head s1) - dist_end_block (real s1) = dist_end_block (head s1)) in H3; try omega.
+        eapply starN_tailstep; eauto.
+      * unfold head; rewrite H2; simpl. intuition eauto. 
+Qed.
+
+Lemma forward_simulation_block_rel: forward_simulation L1 L2.
+Proof.
+  eapply compose_forward_simulations.
+  eapply forward_memo_simulation_1.
+  apply forward_memo_simulation_2.
+Qed.
+
+
+End ForwardSimuBlock_REL.
+
+
+
+(* An instance of the previous scheme, when there is a translation from L1 states to L2 states 
+
+Here, we do not require that the sequence of S2 states does exactly match the sequence of L1 states by trans_state.
+This is because the exact matching is broken in Machblock on "goto" instruction (due to the find_label).
+
+However, the Machblock state after a goto remains "equivalent" to the trans_state of the Mach state in the sense of "equiv_on_next_step" below...
+
+*)
+
+Section ForwardSimuBlock_TRANS.
+
+Variable L1 L2: semantics.
+
+Variable trans_state: state L1 -> state L2.
+
+Definition equiv_on_next_step (P Q: Prop) s2_a s2_b: Prop := 
+  (P -> (forall t s', Step L2 s2_a t s' <-> Step L2 s2_b t s')) /\ (Q -> (forall r, (final_state L2 s2_a r) <-> (final_state L2 s2_b r))).
+
+Definition match_states s1 s2: Prop :=
+  equiv_on_next_step (exists t s1', Step L1 s1 t s1') (exists r, final_state L1 s1 r) s2 (trans_state s1).
+
+Lemma match_states_trans_state s1: match_states s1 (trans_state s1).
+Proof.
+  unfold match_states, equiv_on_next_step. intuition.
+Qed.
+
+Variable dist_end_block: state L1 -> nat.
+
+Hypothesis simu_mid_block:
+  forall s1 t s1', Step L1 s1 t s1' -> (dist_end_block s1)<>0 -> t = E0 /\ dist_end_block s1=S (dist_end_block s1').
+
+Hypothesis public_preserved:
+  forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id.
+
+Hypothesis match_initial_states:
+  forall s1, initial_state L1 s1 -> exists s2, match_states s1 s2 /\ initial_state L2 s2.
+
+Hypothesis match_final_states:
+  forall s1 r, final_state L1 s1 r -> final_state L2 (trans_state s1) r.
+
+Hypothesis final_states_end_block:
+  forall s1 t s1' r, Step L1 s1 t s1' -> final_state L1 s1' r -> dist_end_block s1 = 0.
+
+Hypothesis simu_end_block:
+  forall s1 t s1', starN (step L1) (globalenv L1) (S (dist_end_block s1)) s1 t s1' -> exists s2', Step L2 (trans_state s1) t s2' /\ match_states s1' s2'.
+
+Lemma forward_simulation_block_trans: forward_simulation L1 L2.
+Proof.
+  eapply forward_simulation_block_rel with (dist_end_block:=dist_end_block) (match_states:=match_states); try tauto.
+  + (* final_states *) intros s1 s2 r H1 [H2 H3]. rewrite H3; eauto.
+  + (* simu_end_block *)
+    intros s1 t s1' s2 H1 [H2a H2b]. exploit simu_end_block; eauto.
+    intros (s2' & H3 & H4); econstructor 1; intuition eauto.
+    rewrite H2a; auto.
+    inversion_clear H1. eauto.
+Qed.
+
+End ForwardSimuBlock_TRANS.
diff --git a/extraction/extraction.v b/extraction/extraction.v
index 8ac776ef..6ab2ce3a 100644
--- a/extraction/extraction.v
+++ b/extraction/extraction.v
@@ -167,7 +167,7 @@ Set Extraction AccessOpaque.
 Cd "extraction".
 
 Separate Extraction
-   Asmgen.addptrofs
+   Asm.dummy_function Asmgen.addptrofs Asmgen.storeind_ptr
    Compiler.transf_c_program Compiler.transf_cminor_program
    Cexec.do_initial_state Cexec.do_step Cexec.at_final_state
    Ctypes.merge_attributes Ctypes.remove_attributes Ctypes.build_composite_env
diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v
index 9de80a15..c142185c 100644
--- a/mppa_k1c/Asm.v
+++ b/mppa_k1c/Asm.v
@@ -1,1363 +1,496 @@
-(* *********************************************************************)
-(*                                                                     *)
-(*              The Compcert verified compiler                         *)
-(*                                                                     *)
-(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
-(*           Prashanth Mundkur, SRI International                      *)
-(*                                                                     *)
-(*  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.     *)
-(*                                                                     *)
-(*  The contributions by Prashanth Mundkur are reused and adapted      *)
-(*  under the terms of a Contributor License Agreement between         *)
-(*  SRI International and INRIA.                                       *)
-(*                                                                     *)
-(* *********************************************************************)
-
-(** Abstract syntax and semantics for K1c assembly language. *)
-
-Require Import Coqlib.
-Require Import Maps.
-Require Import AST.
-Require Import Integers.
-Require Import Floats.
-Require Import Values.
-Require Import Memory.
-Require Import Events.
-Require Import Globalenvs.
-Require Import Smallstep.
-Require Import Locations.
-Require Stacklayout.
-Require Import Conventions.
-
-(** * Abstract syntax *)
-
-(** General Purpose registers. *)
-
-Inductive gpreg: Type :=
-  | GPR0:  gpreg | GPR1:  gpreg | GPR2:  gpreg | GPR3:  gpreg | GPR4:  gpreg
-  | GPR5:  gpreg | GPR6:  gpreg | GPR7:  gpreg | GPR8:  gpreg | GPR9:  gpreg
-  | GPR10: gpreg | GPR11: gpreg | GPR12: gpreg | GPR13: gpreg | GPR14: gpreg
-  | GPR15: gpreg | GPR16: gpreg | GPR17: gpreg | GPR18: gpreg | GPR19: gpreg
-  | GPR20: gpreg | GPR21: gpreg | GPR22: gpreg | GPR23: gpreg | GPR24: gpreg
-  | GPR25: gpreg | GPR26: gpreg | GPR27: gpreg | GPR28: gpreg | GPR29: gpreg
-  | GPR30: gpreg | GPR31: gpreg | GPR32: gpreg | GPR33: gpreg | GPR34: gpreg
-  | GPR35: gpreg | GPR36: gpreg | GPR37: gpreg | GPR38: gpreg | GPR39: gpreg
-  | GPR40: gpreg | GPR41: gpreg | GPR42: gpreg | GPR43: gpreg | GPR44: gpreg
-  | GPR45: gpreg | GPR46: gpreg | GPR47: gpreg | GPR48: gpreg | GPR49: gpreg
-  | GPR50: gpreg | GPR51: gpreg | GPR52: gpreg | GPR53: gpreg | GPR54: gpreg
-  | GPR55: gpreg | GPR56: gpreg | GPR57: gpreg | GPR58: gpreg | GPR59: gpreg
-  | GPR60: gpreg | GPR61: gpreg | GPR62: gpreg | GPR63: gpreg.
-
-Definition ireg := gpreg.
-Definition freg := gpreg.
-
-Lemma ireg_eq: forall (x y: ireg), {x=y} + {x<>y}.
-Proof. decide equality. Defined.
-
-Lemma freg_eq: forall (x y: freg), {x=y} + {x<>y}.
-Proof. decide equality. Defined.
-
-(** We model the following registers of the RISC-V architecture. *)
-
-Inductive preg: Type :=
-  | IR: gpreg -> preg                   (**r integer registers *)
-  | FR: gpreg -> preg                   (**r float registers   *)
-  | RA: preg                            (**r return address    *)
-  | PC: preg.                           (**r program counter   *)
-
-Coercion IR: gpreg >-> preg.
-Coercion FR: gpreg >-> preg.
-
-Lemma preg_eq: forall (x y: preg), {x=y} + {x<>y}.
-Proof. decide equality. apply ireg_eq. apply freg_eq. Defined.
-
-Module PregEq.
-  Definition t  := preg.
-  Definition eq := preg_eq.
-End PregEq.
-
-Module Pregmap := EMap(PregEq).
-
-(** Conventional names for stack pointer ([SP]) and return address ([RA]). *)
-
-Notation "'SP'" := GPR12 (only parsing) : asm.
-Notation "'FP'" := GPR10 (only parsing) : asm.
-Notation "'RTMP'" := GPR31 (only parsing) : asm.
-
-Inductive btest: Type :=
-  | BTdnez                              (**r Double Not Equal to Zero *)
-  | BTdeqz                              (**r Double Equal to Zero *)
-  | BTdltz                              (**r Double Less Than Zero *)
-  | BTdgez                              (**r Double Greater Than or Equal to Zero *)
-  | BTdlez                              (**r Double Less Than or Equal to Zero *)
-  | BTdgtz                              (**r Double Greater Than Zero *)
-(*| BTodd                               (**r Odd (LSB Set) *)
-  | BTeven                              (**r Even (LSB Clear) *)
-*)| BTwnez                              (**r Word Not Equal to Zero *)
-  | BTweqz                              (**r Word Equal to Zero *)
-  | BTwltz                              (**r Word Less Than Zero *)
-  | BTwgez                              (**r Word Greater Than or Equal to Zero *)
-  | BTwlez                              (**r Word Less Than or Equal to Zero *)
-  | BTwgtz                              (**r Word Greater Than Zero *)
-  .
-
-Inductive itest: Type :=
-  | ITne                                (**r Not Equal *)
-  | ITeq                                (**r Equal *)
-  | ITlt                                (**r Less Than *)
-  | ITge                                (**r Greater Than or Equal *)
-  | ITle                                (**r Less Than or Equal *)
-  | ITgt                                (**r Greater Than *)
-  | ITneu                               (**r Unsigned Not Equal *)
-  | ITequ                               (**r Unsigned Equal *)
-  | ITltu                               (**r Less Than Unsigned *)
-  | ITgeu                               (**r Greater Than or Equal Unsigned *)
-  | ITleu                               (**r Less Than or Equal Unsigned *)
-  | ITgtu                               (**r Greater Than Unsigned *)
-  (* Not used yet *)
-  | ITall                               (**r All Bits Set in Mask *)
-  | ITnall                              (**r Not All Bits Set in Mask *)
-  | ITany                               (**r Any Bits Set in Mask *)
-  | ITnone                              (**r Not Any Bits Set in Mask *)
-  .
-
-(** Offsets for load and store instructions.  An offset is either an
-  immediate integer or the low part of a symbol. *)
-
-Inductive offset : Type :=
-  | Ofsimm (ofs: ptrofs)
-  | Ofslow (id: ident) (ofs: ptrofs).
-
-(** We model a subset of the K1c instruction set. In particular, we do not
-  support floats yet.
-
-  Although it is possible to use the 32-bits mode, for now we don't support it.
-
-  We follow a design close to the one used for the Risc-V port: one set of
-  pseudo-instructions for 32-bit integer arithmetic, with suffix W, another
-  set for 64-bit integer arithmetic, with suffix L.
-
-  When mapping to actual instructions, the OCaml code in TargetPrinter.ml
-  throws an error if we are not in 64-bits mode.
-*)
-
-Definition label := positive.
-
-(** A note on immediates: there are various constraints on immediate
-  operands to K1c instructions.  We do not attempt to capture these
-  restrictions in the abstract syntax nor in the semantics.  The
-  assembler will emit an error if immediate operands exceed the
-  representable range.  Of course, our K1c generator (file
-  [Asmgen]) is careful to respect this range. *)
-
-(** Instructions to be expanded *)
-Inductive ex_instruction : Type :=
-  (* Pseudo-instructions *)
-  | Pallocframe (sz: Z) (pos: ptrofs)               (**r allocate new stack frame *)
-  | Pfreeframe  (sz: Z) (pos: ptrofs)               (**r deallocate stack frame and restore previous frame *)
-  | Plabel  (lbl: label)                            (**r define a code label *)
-  | Ploadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the address of a symbol *)
-(*| Ploadsymbol_high (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the high part of the address of a symbol *)
-  | Ploadli (rd: ireg) (i: int64)                   (**r load an immediate int64 *)
-  | Ploadfi (rd: freg) (f: float)                   (**r load an immediate float *)
-  | Ploadsi (rd: freg) (f: float32)                 (**r load an immediate single *)
-  | Pbtbl   (r: ireg)  (tbl: list label)            (**r N-way branch through a jump table *) *)
-  | Pbuiltin: external_function -> list (builtin_arg preg)
-              -> builtin_res preg -> ex_instruction   (**r built-in function (pseudo) *)
-  (* Instructions not generated by Asmgen (most likely result of AsmExpand) *)
-    (* BCU *)
-  | Pawait
-  | Pbarrier
-  | Pdoze
-  | Pwfxl (rs1 rs2: ireg)
-  | Pwfxm (rs1 rs2: ireg)
-  | Pinvaldtlb
-  | Pinvalitlb
-  | Pprobetlb
-  | Preadtlb
-  | Psleep
-  | Pstop
-  | Psyncgroup (rs: ireg)
-  | Ptlbwrite
-
-    (* LSU *)
-  | Pafda (rd rs1 rs2: ireg)
-  | Paldc (rd rs: ireg)
-  | Pdinval
-  | Pdinvall (rs: ireg)
-  | Pdtouchl (rs: ireg)
-  | Pdzerol (rs: ireg)
-  | Pfence
-  | Piinval
-  | Piinvals (rs: ireg)
-  | Pitouchl (rs: ireg)
-  | Plbsu (rd rs: ireg)
-  | Plbzu (rd rs: ireg)
-  | Pldu (rd rs: ireg)
-  | Plhsu (rd rs: ireg)
-  | Plhzu (rd rs: ireg)
-  | Plwzu (rd rs: ireg)
-
-    (* ALU *)
-  | Paddhp (rd rs1 rs2: ireg)
-  | Padds (rd rs1 rs2: ireg)
-  | Pbwlu (rd rs1 rs2 rs3 rs4 rs5: ireg)
-  | Pbwluhp (rd rs1 rs2 rs3: ireg)
-  | Pbwluwp (rd rs1 rs2 rs3: ireg)
-  | Pcbs (rd rs: ireg)
-  | Pcbsdl (rd rs: ireg)
-  | Pclz (rd rs: ireg)
-  | Pclzw (rd rs: ireg)
-  | Pclzd (rd rs: ireg)
-  | Pclzdl (rd rs: ireg)
-  | Pcmove (rd rs1 rs2 rs3: ireg)
-  | Pctz (rd rs: ireg)
-  | Pctzw (rd rs: ireg)
-  | Pctzd (rd rs: ireg)
-  | Pctzdl (rd rs: ireg)
-  | Pextfz (rd rs1 rs2 rs3: ireg)
-  | Plandhp (rd rs1 rs2 rs3: ireg)
-  | Psat (rd rs1 rs2: ireg)
-  | Psatd (rd rs1 rs2: ireg)
-  | Psbfhp (rd rs1 rs2: ireg)
-  | Psbmm8 (rd rs1 rs2: ireg)
-  | Psbmmt8 (rd rs1 rs2: ireg)
-  | Psllhps (rd rs1 rs2: ireg)
-  | Psrahps (rd rs1 rs2: ireg)
-  | Pstsu (rd rs1 rs2: ireg)
-  | Pstsud (rd rs1 rs2: ireg)
-.
-
-(** The pseudo-instructions are the following:
-
-- [Plabel]: define a code label at the current program point.
-
-- [Ploadsymbol]: load the address of a symbol in an integer register.
-  Expands to the [la] assembler pseudo-instruction, which does the right
-  thing even if we are in PIC mode.
-
-- [Ploadli rd ival]: load an immediate 64-bit integer into an integer
-  register rd.  Expands to a load from an address in the constant data section,
-  using the integer register x31 as temporary:
-<<
-        lui x31, %hi(lbl)
-        ld rd, %lo(lbl)(x31)
-lbl:
-        .quad ival
->>
-
-- [Ploadfi rd fval]: similar to [Ploadli] but loads a double FP constant fval
-  into a float register rd.
-
-- [Ploadsi rd fval]: similar to [Ploadli] but loads a singe FP constant fval
-  into a float register rd.
-
-- [Pallocframe sz pos]: in the formal semantics, this
-  pseudo-instruction allocates a memory block with bounds [0] and
-  [sz], stores the value of the stack pointer at offset [pos] in this
-  block, and sets the stack pointer to the address of the bottom of
-  this block.
-  In the printed ASM assembly code, this allocation is:
-<<
-        mv      x30, sp
-        sub     sp,  sp, #sz
-        sw      x30, #pos(sp)
->>
-  This cannot be expressed in our memory model, which does not reflect
-  the fact that stack frames are adjacent and allocated/freed
-  following a stack discipline.
-
-- [Pfreeframe sz pos]: in the formal semantics, this pseudo-instruction
-  reads the word at [pos] of the block pointed by the stack pointer,
-  frees this block, and sets the stack pointer to the value read.
-  In the printed ASM assembly code, this freeing is just an increment of [sp]:
-<<
-        add     sp,  sp, #sz
->>
-  Again, our memory model cannot comprehend that this operation
-  frees (logically) the current stack frame.
-
-- [Pbtbl reg table]: this is a N-way branch, implemented via a jump table
-  as follows:
-<<
-        la      x31, table
-        add     x31, x31, reg
-        jr      x31
-table:  .long   table[0], table[1], ...
->>
-  Note that [reg] contains 4 times the index of the desired table entry.
-
-- [Pseq rd rs1 rs2]: since unsigned comparisons have particular
-  semantics for pointers, we cannot encode equality directly using
-  xor/sub etc, which have only integer semantics.
-<<
-        xor     rd, rs1, rs2
-        sltiu   rd, rd, 1
->>
-  The [xor] is omitted if one of [rs1] and [rs2] is [x0].
-
-- [Psne rd rs1 rs2]: similarly for unsigned inequality.
-<<
-        xor     rd, rs1, rs2
-        sltu    rd, x0, rd
->>
-*)
-
-(** Control Flow instructions *)
-Inductive cf_instruction : Type :=
-  | Pget    (rd: ireg) (rs: preg)                   (**r get system register *)
-  | Pset    (rd: preg) (rs: ireg)                   (**r set system register *)
-  | Pret                                            (**r return *)
-  | Pcall   (l: label)                              (**r function call *)
-  (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *)
-  | Pgoto   (l: label)                              (**r goto *)
-  | Pj_l    (l: label)                              (**r jump to label *)
-  (* Conditional branches *)
-  | Pcb     (bt: btest) (r: ireg) (l: label)        (**r branch based on btest *)
-  | Pcbu    (bt: btest) (r: ireg) (l: label)        (**r branch based on btest with unsigned semantics *)
-.
-
-(** Loads **)
-Inductive ld_instruction : Type :=
-  | Plb     (rd: ireg) (ra: ireg) (ofs: offset)     (**r load byte *)
-  | Plbu    (rd: ireg) (ra: ireg) (ofs: offset)     (**r load byte unsigned *)
-  | Plh     (rd: ireg) (ra: ireg) (ofs: offset)     (**r load half word *)
-  | Plhu    (rd: ireg) (ra: ireg) (ofs: offset)     (**r load half word unsigned *)
-  | Plw     (rd: ireg) (ra: ireg) (ofs: offset)     (**r load int32 *)
-  | Plw_a   (rd: ireg) (ra: ireg) (ofs: offset)     (**r load any32 *)
-  | Pld     (rd: ireg) (ra: ireg) (ofs: offset)     (**r load int64 *)
-  | Pld_a   (rd: ireg) (ra: ireg) (ofs: offset)     (**r load any64 *)
-  | Pfls    (rd: freg) (ra: ireg) (ofs: offset)     (**r load float *)
-  | Pfld     (rd: freg) (ra: ireg) (ofs: offset)    (**r load 64-bit float *)
-.
-
-(** Stores **)
-Inductive st_instruction : Type :=
-  | Psb     (rs: ireg) (ra: ireg) (ofs: offset)     (**r store byte *)
-  | Psh     (rs: ireg) (ra: ireg) (ofs: offset)     (**r store half byte *)
-  | Psw     (rs: ireg) (ra: ireg) (ofs: offset)     (**r store int32 *)
-  | Psw_a   (rs: ireg) (ra: ireg) (ofs: offset)     (**r store any32 *)
-  | Psd     (rs: ireg) (ra: ireg) (ofs: offset)     (**r store int64 *)
-  | Psd_a   (rs: ireg) (ra: ireg) (ofs: offset)     (**r store any64 *)
-  | Pfss    (rs: freg) (ra: ireg) (ofs: offset)     (**r store float *)
-  | Pfsd     (rd: freg) (ra: ireg) (ofs: offset)    (**r store 64-bit float *)
-.
-
-(** Arithmetic instructions **)
-Inductive arith_name_r : Type :=
-  | Pcvtw2l                                         (**r Convert Word to Long *)
-.
-
-Inductive arith_name_rr : Type :=
-  | Pmv                                             (**r register move *)
-  | Pnegw                                           (**r negate word *)
-  | Pnegl                                           (**r negate long *)
-  | Pfnegd                                          (**r float negate double *)
-  | Pcvtl2w                                         (**r Convert Long to Word *)
-  | Pmvw2l                                          (**r Move Convert Word to Long *)
-.
-
-Inductive arith_name_ri32 : Type :=
-  | Pmake                                           (**r load immediate *)
-.
-
-Inductive arith_name_ri64 : Type :=
-  | Pmakel                                          (**r load immediate long *)
-.
-
-Inductive arith_name_rrr : Type :=
-  | Pcompw  (it: itest)                             (**r comparison word *)
-  | Pcompl  (it: itest)                             (**r comparison long *)
-
-  | Paddw                                           (**r add word *)
-  | Psubw                                           (**r sub word *)
-  | Pmulw                                           (**r mul word *)
-  | Pandw                                           (**r and word *)
-  | Porw                                            (**r or word *)
-  | Pxorw                                           (**r xor word *)
-  | Psraw                                           (**r shift right arithmetic word *)
-  | Psrlw                                           (**r shift right logical word *)
-  | Psllw                                           (**r shift left logical word *)
-
-  | Paddl                                           (**r add long *)
-  | Psubl                                           (**r sub long *)
-  | Pandl                                           (**r and long *)
-  | Porl                                            (**r or long *)
-  | Pxorl                                           (**r xor long *)
-  | Pmull                                           (**r mul long (low part) *)
-  | Pslll                                           (**r shift left logical long *)
-  | Psrll                                           (**r shift right logical long *)
-  | Psral                                           (**r shift right arithmetic long *)
-.
-
-Inductive arith_name_rri32 : Type :=
-  | Pcompiw (it: itest)                             (**r comparison imm word *)
-
-  | Paddiw                                          (**r add imm word *)
-  | Pandiw                                          (**r and imm word *)
-  | Poriw                                           (**r or imm word *)
-  | Pxoriw                                          (**r xor imm word *)
-  | Psraiw                                          (**r shift right arithmetic imm word *)
-  | Psrliw                                          (**r shift right logical imm word *)
-  | Pslliw                                          (**r shift left logical imm word *)
-
-  | Psllil                                          (**r shift left logical immediate long *)
-  | Psrlil                                          (**r shift right logical immediate long *)
-  | Psrail                                          (**r shift right arithmetic immediate long *)
-.
-
-Inductive arith_name_rri64 : Type :=
-  | Pcompil (it: itest)                             (**r comparison imm long *)
-  | Paddil                                          (**r add immediate long *) 
-  | Pandil                                          (**r and immediate long *) 
-  | Poril                                           (**r or immediate long *) 
-  | Pxoril                                          (**r xor immediate long *) 
-.
-
-Inductive ar_instruction : Type :=
-  | PArithR     (i: arith_name_r)     (rd: ireg)
-  | PArithRR    (i: arith_name_rr)    (rd rs: ireg)
-  | PArithRI32  (i: arith_name_ri32)  (rd: ireg) (imm: int)
-  | PArithRI64  (i: arith_name_ri64)  (rd: ireg) (imm: int64)
-  | PArithRRR   (i: arith_name_rrr)   (rd rs1 rs2: ireg)
-  | PArithRRI32 (i: arith_name_rri32) (rd rs: ireg) (imm: int)
-  | PArithRRI64 (i: arith_name_rri64) (rd rs: ireg) (imm: int64)
-.
-
-Coercion PArithR:       arith_name_r        >-> Funclass.
-Coercion PArithRR:      arith_name_rr       >-> Funclass.
-Coercion PArithRI32:    arith_name_ri32     >-> Funclass.
-Coercion PArithRI64:    arith_name_ri64     >-> Funclass.
-Coercion PArithRRR:     arith_name_rrr      >-> Funclass.
-Coercion PArithRRI32:   arith_name_rri32    >-> Funclass.
-Coercion PArithRRI64:   arith_name_rri64    >-> Funclass.
-
-(*| Pfence                                          (**r fence *)
-
-  (* floating point register move *)
-  | Pfmv     (rd: freg) (rs: freg)                  (**r move *)
-  | Pfmvxs   (rd: ireg) (rs: freg)                  (**r move FP single to integer register *)
-  | Pfmvxd   (rd: ireg) (rs: freg)                  (**r move FP double to integer register *)
-
-*)(* 32-bit (single-precision) floating point *)
-
-(*| Pfnegs   (rd: freg) (rs: freg)                  (**r negation *)
-  | Pfabss   (rd: freg) (rs: freg)                  (**r absolute value *)
-
-  | Pfadds   (rd: freg) (rs1 rs2: freg)             (**r addition *)
-  | Pfsubs   (rd: freg) (rs1 rs2: freg)             (**r subtraction *)
-  | Pfmuls   (rd: freg) (rs1 rs2: freg)             (**r multiplication *)
-  | Pfdivs   (rd: freg) (rs1 rs2: freg)             (**r division *)
-  | Pfmins   (rd: freg) (rs1 rs2: freg)             (**r minimum *)
-  | Pfmaxs   (rd: freg) (rs1 rs2: freg)             (**r maximum *)
-
-  | Pfeqs    (rd: ireg) (rs1 rs2: freg)             (**r compare equal *)
-  | Pflts    (rd: ireg) (rs1 rs2: freg)             (**r compare less-than *)
-  | Pfles    (rd: ireg) (rs1 rs2: freg)             (**r compare less-than/equal *)
-
-  | Pfsqrts  (rd: freg) (rs: freg)                  (**r square-root *)
-
-  | Pfmadds  (rd: freg) (rs1 rs2 rs3: freg)         (**r fused multiply-add *)
-  | Pfmsubs  (rd: freg) (rs1 rs2 rs3: freg)         (**r fused multiply-sub *)
-  | Pfnmadds (rd: freg) (rs1 rs2 rs3: freg)         (**r fused negated multiply-add *)
-  | Pfnmsubs (rd: freg) (rs1 rs2 rs3: freg)         (**r fused negated multiply-sub *)
-
-  | Pfcvtws  (rd: ireg) (rs: freg)                  (**r float32 -> int32 conversion *)
-  | Pfcvtwus (rd: ireg) (rs: freg)                  (**r float32 -> unsigned int32 conversion *)
-  | Pfcvtsw  (rd: freg) (rs: ireg)                 (**r int32 -> float32 conversion *)
-  | Pfcvtswu (rd: freg) (rs: ireg)                 (**r unsigned int32 -> float32 conversion *)
-
-  | Pfcvtls  (rd: ireg) (rs: freg)                  (**r float32 -> int64 conversion *)
-  | Pfcvtlus (rd: ireg) (rs: freg)                  (**r float32 -> unsigned int64 conversion *)
-  | Pfcvtsl  (rd: freg) (rs: ireg)                 (**r int64 -> float32 conversion *)
-  | Pfcvtslu (rd: freg) (rs: ireg)                 (**r unsigned int 64-> float32 conversion *)
-
-*)(* 64-bit (double-precision) floating point *)
-(*| Pfld_a   (rd: freg) (ra: ireg) (ofs: offset)    (**r load any64 *)
-  | Pfsd_a   (rd: freg) (ra: ireg) (ofs: offset)    (**r store any64 *)
-
-  | Pfabsd   (rd: freg) (rs: freg)                  (**r absolute value *)
-
-  | Pfaddd   (rd: freg) (rs1 rs2: freg)             (**r addition *)
-  | Pfsubd   (rd: freg) (rs1 rs2: freg)             (**r subtraction *)
-  | Pfmuld   (rd: freg) (rs1 rs2: freg)             (**r multiplication *)
-  | Pfdivd   (rd: freg) (rs1 rs2: freg)             (**r division *)
-  | Pfmind   (rd: freg) (rs1 rs2: freg)             (**r minimum *)
-  | Pfmaxd   (rd: freg) (rs1 rs2: freg)             (**r maximum *)
-
-  | Pfeqd    (rd: ireg) (rs1 rs2: freg)             (**r compare equal *)
-  | Pfltd    (rd: ireg) (rs1 rs2: freg)             (**r compare less-than *)
-  | Pfled    (rd: ireg) (rs1 rs2: freg)             (**r compare less-than/equal *)
-
-  | Pfsqrtd  (rd: freg) (rs: freg)                  (**r square-root *)
-
-  | Pfmaddd  (rd: freg) (rs1 rs2 rs3: freg)         (**r fused multiply-add *)
-  | Pfmsubd  (rd: freg) (rs1 rs2 rs3: freg)         (**r fused multiply-sub *)
-  | Pfnmaddd (rd: freg) (rs1 rs2 rs3: freg)         (**r fused negated multiply-add *)
-  | Pfnmsubd (rd: freg) (rs1 rs2 rs3: freg)         (**r fused negated multiply-sub *)
-
-  | Pfcvtwd  (rd: ireg) (rs: freg)                  (**r float -> int32 conversion *)
-  | Pfcvtwud (rd: ireg) (rs: freg)                  (**r float -> unsigned int32 conversion *)
-  | Pfcvtdw  (rd: freg) (rs: ireg)                 (**r int32 -> float conversion *)
-  | Pfcvtdwu (rd: freg) (rs: ireg)                 (**r unsigned int32 -> float conversion *)
-
-  | Pfcvtld  (rd: ireg) (rs: freg)                  (**r float -> int64 conversion *)
-  | Pfcvtlud (rd: ireg) (rs: freg)                  (**r float -> unsigned int64 conversion *)
-  | Pfcvtdl  (rd: freg) (rs: ireg)                 (**r int64 -> float conversion *)
-  | Pfcvtdlu (rd: freg) (rs: ireg)                 (**r unsigned int64 -> float conversion *)
-
-  | Pfcvtds  (rd: freg) (rs: freg)                  (**r float32 -> float   *)
-  | Pfcvtsd  (rd: freg) (rs: freg)                  (**r float   -> float32 *)
-*)
-
-Inductive instruction : Type :=
-  | PExpand         (i: ex_instruction)
-  | PControlFlow    (i: cf_instruction)
-  | PLoad           (i: ld_instruction)
-  | PStore          (i: st_instruction)
-  | PArith          (i: ar_instruction)
-.
-
-Coercion PExpand:       ex_instruction >-> instruction.
-Coercion PControlFlow:  cf_instruction >-> instruction.
-Coercion PLoad:         ld_instruction >-> instruction.
-Coercion PStore:        st_instruction >-> instruction.
-Coercion PArith:        ar_instruction >-> instruction.
-
-Definition code := list instruction.
-Record function : Type := mkfunction { fn_sig: signature; fn_code: code }.
-Definition fundef := AST.fundef function.
-Definition program := AST.program fundef unit.
-
-(** * Operational semantics *)
-
-(** The semantics operates over a single mapping from registers
-  (type [preg]) to values.  We maintain
-  the convention that integer registers are mapped to values of
-  type [Tint] or [Tlong] (in 64 bit mode),
-  and float registers to values of type [Tsingle] or [Tfloat]. *)
-
-Definition regset := Pregmap.t val.
-Definition genv := Genv.t fundef unit.
-
-Definition getw (rs: regset) (r: ireg) : val :=
-  match r with
-  | _ => rs r
-  end.
-
-Definition getl (rs: regset) (r: ireg) : val :=
-  match r with
-  | _ => rs r
-  end.
-
-Notation "a # b" := (a b) (at level 1, only parsing) : asm.
-Notation "a ## b" := (getw a b) (at level 1) : asm.
-Notation "a ### b" := (getl a b) (at level 1) : asm.
-Notation "a # b <- c" := (Pregmap.set b c a) (at level 1, b at next level) : asm.
-
-Open Scope asm.
-
-(** Undefining some registers *)
-
-Fixpoint undef_regs (l: list preg) (rs: regset) : regset :=
-  match l with
-  | nil => rs
-  | r :: l' => undef_regs l' (rs#r <- Vundef)
-  end.
-
-(** Assigning a register pair *)
-
-Definition set_pair (p: rpair preg) (v: val) (rs: regset) : regset :=
-  match p with
-  | One r => rs#r <- v
-  | Twolong rhi rlo => rs#rhi <- (Val.hiword v) #rlo <- (Val.loword v)
-  end.
-
-(** Assigning multiple registers *)
-
-Fixpoint set_regs (rl: list preg) (vl: list val) (rs: regset) : regset :=
-  match rl, vl with
-  | r1 :: rl', v1 :: vl' => set_regs rl' vl' (rs#r1 <- v1)
-  | _, _ => rs
-  end.
-
-(** Assigning the result of a builtin *)
-
-Fixpoint set_res (res: builtin_res preg) (v: val) (rs: regset) : regset :=
-  match res with
-  | BR r => rs#r <- v
-  | BR_none => rs
-  | BR_splitlong hi lo => set_res lo (Val.loword v) (set_res hi (Val.hiword v) rs)
-  end.
-
-Section RELSEM.
-
-(** Looking up instructions in a code sequence by position. *)
-
-Fixpoint find_instr (pos: Z) (c: code) {struct c} : option instruction :=
-  match c with
-  | nil => None
-  | i :: il => if zeq pos 0 then Some i else find_instr (pos - 1) il
-  end.
-
-(** Position corresponding to a label *)
-
-Definition is_label (lbl: label) (instr: instruction) : bool :=
-  match instr with
-  | Plabel lbl' => if peq lbl lbl' then true else false
-  | _ => false
-  end.
-
-Lemma is_label_correct:
-  forall lbl instr,
-  if is_label lbl instr then instr = Plabel lbl else instr <> Plabel lbl.
-Proof.
-  intros.  destruct instr; simpl; try discriminate.
-  destruct i; simpl; try discriminate.
-  case (peq lbl lbl0); intro; congruence.
-Qed.
-
-Fixpoint label_pos (lbl: label) (pos: Z) (c: code) {struct c} : option Z :=
-  match c with
-  | nil => None
-  | instr :: c' =>
-      if is_label lbl instr then Some (pos + 1) else label_pos lbl (pos + 1) c'
-  end.
-
-Variable ge: genv.
-
-(** The two functions below axiomatize how the linker processes
-  symbolic references [symbol + offset)] and splits their
-  actual values into a 20-bit high part [%hi(symbol + offset)] and 
-  a 12-bit low part [%lo(symbol + offset)]. *)
-
-Parameter low_half: genv -> ident -> ptrofs -> ptrofs.
-Parameter high_half: genv -> ident -> ptrofs -> val.
-
-(** The fundamental property of these operations is that, when applied
-  to the address of a symbol, their results can be recombined by
-  addition, rebuilding the original address. *)
-
-Axiom low_high_half:
-  forall id ofs,
-  Val.offset_ptr (high_half ge id ofs) (low_half ge id ofs) = Genv.symbol_address ge id ofs.
-
-(** The semantics is purely small-step and defined as a function
-  from the current state (a register set + a memory state)
-  to either [Next rs' m'] where [rs'] and [m'] are the updated register
-  set and memory state after execution of the instruction at [rs#PC],
-  or [Stuck] if the processor is stuck. *)
-
-Inductive outcome: Type :=
-  | Next:  regset -> mem -> outcome
-  | Stuck: outcome.
-
-(** Manipulations over the [PC] register: continuing with the next
-  instruction ([nextinstr]) or branching to a label ([goto_label]). *)
-
-Definition nextinstr (rs: regset) :=
-  rs#PC <- (Val.offset_ptr rs#PC Ptrofs.one).
-
-Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) :=
-  match label_pos lbl 0 (fn_code f) with
-  | None => Stuck
-  | Some pos =>
-      match rs#PC with
-      | Vptr b ofs => Next (rs#PC <- (Vptr b (Ptrofs.repr pos))) m
-      | _          => Stuck
-      end
-  end.
-
-(** Auxiliaries for memory accesses *)
-
-Definition eval_offset (ofs: offset) : ptrofs :=
-  match ofs with
-  | Ofsimm n => n
-  | Ofslow id delta => low_half ge id delta
-  end.
-
-Definition exec_load (chunk: memory_chunk) (rs: regset) (m: mem)
-                     (d: preg) (a: ireg) (ofs: offset) :=
-  match Mem.loadv chunk m (Val.offset_ptr (rs a) (eval_offset ofs)) with
-  | None => Stuck
-  | Some v => Next (nextinstr (rs#d <- v)) m
-  end.
-
-Definition exec_store (chunk: memory_chunk) (rs: regset) (m: mem)
-                      (s: preg) (a: ireg) (ofs: offset) :=
-  match Mem.storev chunk m (Val.offset_ptr (rs a) (eval_offset ofs)) (rs s) with
-  | None => Stuck
-  | Some m' => Next (nextinstr rs) m'
-  end.
-
-(** Evaluating a branch *)
-
-Definition eval_branch (f: function) (l: label) (rs: regset) (m: mem) (res: option bool) : outcome :=
-  match res with
-    | Some true  => goto_label f l rs m
-    | Some false => Next (nextinstr rs) m
-    | None => Stuck
-  end.
-
-Inductive signedness: Type := Signed | Unsigned.
-
-Inductive intsize: Type := Int | Long.
-
-Definition itest_for_cmp (c: comparison) (s: signedness) :=
-  match c, s with
-  | Cne, Signed => ITne
-  | Ceq, Signed => ITeq
-  | Clt, Signed => ITlt
-  | Cge, Signed => ITge
-  | Cle, Signed => ITle
-  | Cgt, Signed => ITgt
-  | Cne, Unsigned => ITneu
-  | Ceq, Unsigned => ITequ
-  | Clt, Unsigned => ITltu
-  | Cge, Unsigned => ITgeu
-  | Cle, Unsigned => ITleu
-  | Cgt, Unsigned => ITgtu
-  end.
-
-(* CoMPare Signed Words to Zero *)
-Definition btest_for_cmpswz (c: comparison) :=
-  match c with
-  | Cne => BTwnez
-  | Ceq => BTweqz
-  | Clt => BTwltz
-  | Cge => BTwgez
-  | Cle => BTwlez
-  | Cgt => BTwgtz
-  end.
-
-(* CoMPare Signed Doubles to Zero *)
-Definition btest_for_cmpsdz (c: comparison) :=
-  match c with
-  | Cne => BTdnez
-  | Ceq => BTdeqz
-  | Clt => BTdltz
-  | Cge => BTdgez
-  | Cle => BTdlez
-  | Cgt => BTdgtz
-  end.
-
-Definition cmp_for_btest (bt: btest) :=
-  match bt with
-  | BTwnez => (Some Cne, Int)
-  | BTweqz => (Some Ceq, Int)
-  | BTwltz => (Some Clt, Int)
-  | BTwgez => (Some Cge, Int)
-  | BTwlez => (Some Cle, Int)
-  | BTwgtz => (Some Cgt, Int)
-
-  | BTdnez => (Some Cne, Long)
-  | BTdeqz => (Some Ceq, Long)
-  | BTdltz => (Some Clt, Long)
-  | BTdgez => (Some Cge, Long)
-  | BTdlez => (Some Cle, Long)
-  | BTdgtz => (Some Cgt, Long)
-  end.
-
-Definition cmpu_for_btest (bt: btest) :=
-  match bt with
-  | BTwnez => (Some Cne, Int)
-  | BTweqz => (Some Ceq, Int)
-  | BTdnez => (Some Cne, Long)
-  | BTdeqz => (Some Ceq, Long)
-  | _ => (None, Int)
-  end.
-
-(** Comparing integers *)
-Definition compare_int (t: itest) (v1 v2: val) (m: mem): val :=
-  match t with
-  | ITne  => Val.cmp Cne v1 v2
-  | ITeq  => Val.cmp Ceq v1 v2
-  | ITlt  => Val.cmp Clt v1 v2
-  | ITge  => Val.cmp Cge v1 v2
-  | ITle  => Val.cmp Cle v1 v2
-  | ITgt  => Val.cmp Cgt v1 v2
-  | ITneu => Val.cmpu (Mem.valid_pointer m) Cne v1 v2
-  | ITequ => Val.cmpu (Mem.valid_pointer m) Ceq v1 v2
-  | ITltu => Val.cmpu (Mem.valid_pointer m) Clt v1 v2
-  | ITgeu => Val.cmpu (Mem.valid_pointer m) Cge v1 v2
-  | ITleu => Val.cmpu (Mem.valid_pointer m) Cle v1 v2
-  | ITgtu => Val.cmpu (Mem.valid_pointer m) Cgt v1 v2
-  | ITall
-  | ITnall
-  | ITany
-  | ITnone => Vundef
-  end.
-
-Definition compare_long (t: itest) (v1 v2: val) (m: mem): val :=
-  let res := match t with
-  | ITne  => Val.cmpl Cne v1 v2
-  | ITeq  => Val.cmpl Ceq v1 v2
-  | ITlt  => Val.cmpl Clt v1 v2
-  | ITge  => Val.cmpl Cge v1 v2
-  | ITle  => Val.cmpl Cle v1 v2
-  | ITgt  => Val.cmpl Cgt v1 v2
-  | ITneu => Val.cmplu (Mem.valid_pointer m) Cne v1 v2
-  | ITequ => Val.cmplu (Mem.valid_pointer m) Ceq v1 v2
-  | ITltu => Val.cmplu (Mem.valid_pointer m) Clt v1 v2
-  | ITgeu => Val.cmplu (Mem.valid_pointer m) Cge v1 v2
-  | ITleu => Val.cmplu (Mem.valid_pointer m) Cle v1 v2
-  | ITgtu => Val.cmplu (Mem.valid_pointer m) Cgt v1 v2
-  | ITall
-  | ITnall
-  | ITany
-  | ITnone => Some Vundef
-  end in 
-  match res with
-  | Some v => v
-  | None => Vundef
-  end
-  .
-
-(** Execution of a single instruction [i] in initial state [rs] and
-    [m].  Return updated state.  For instructions that correspond to
-    actual RISC-V instructions, the cases are straightforward
-    transliterations of the informal descriptions given in the RISC-V
-    user-mode specification.  For pseudo-instructions, refer to the
-    informal descriptions given above.
-
-    Note that we set to [Vundef] the registers used as temporaries by
-    the expansions of the pseudo-instructions, so that the RISC-V code
-    we generate cannot use those registers to hold values that must
-    survive the execution of the pseudo-instruction. *)
-
-Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : outcome :=
-(** Get/Set system registers *)
-  match i with
-  | Pget rd ra =>
-    match ra with
-    | RA => Next (nextinstr (rs#rd <- (rs#ra))) m
-    | _  => Stuck
-    end
-  | Pset ra rd =>
-    match ra with
-    | RA => Next (nextinstr (rs#ra <- (rs#rd))) m
-    | _  => Stuck
-    end
-
-(** Branch Control Unit instructions *)
-  | Pret =>
-      Next (rs#PC <- (rs#RA)) m
-  | Pcall s =>
-      Next (rs#RA <- (Val.offset_ptr (rs#PC) Ptrofs.one)#PC <- (Genv.symbol_address ge s Ptrofs.zero)) m
-  | Pgoto s =>
-      Next (rs#PC <- (Genv.symbol_address ge s Ptrofs.zero)) m
-  | Pj_l l =>
-      goto_label f l rs m
-  | Pcb bt r l =>
-      match cmp_for_btest bt with
-      | (Some c, Int)  => eval_branch f l rs m (Val.cmp_bool c rs##r (Vint (Int.repr 0)))
-      | (Some c, Long) => eval_branch f l rs m (Val.cmpl_bool c rs###r (Vlong (Int64.repr 0)))
-      | (None, _) => Stuck
-      end
-  | Pcbu bt r l => 
-      match cmpu_for_btest bt with
-      | (Some c, Int) => eval_branch f l rs m (Val.cmpu_bool (Mem.valid_pointer m) c rs##r (Vint (Int.repr 0)))
-      | (Some c, Long) => eval_branch f l rs m (Val.cmplu_bool (Mem.valid_pointer m) c rs###r (Vlong (Int64.repr 0)))
-      | (None, _) => Stuck
-      end
-
-(** Arithmetic Instructions *)
-  | PArithR n d =>
-      match n with
-      | Pcvtw2l => Next (nextinstr (rs#d <- (Val.longofint rs#d))) m
-      end
-  
-  | PArithRR n d s =>
-      match n with
-      | Pmv => Next (nextinstr (rs#d <- (rs#s))) m
-      | Pnegw => Next (nextinstr (rs#d <- (Val.neg rs###s))) m
-      | Pnegl => Next (nextinstr (rs#d <- (Val.negl rs###s))) m
-      | Pfnegd => Next (nextinstr (rs#d <- (Val.negf rs#s))) m
-      | Pcvtl2w => Next (nextinstr (rs#d <- (Val.loword rs###s))) m
-      | Pmvw2l => Next (nextinstr (rs#d <- (Val.longofint rs#s))) m
-      end
-
-  | PArithRI32 n d i =>
-      match n with
-      | Pmake => Next (nextinstr (rs#d <- (Vint i))) m
-      end
-
-  | PArithRI64 n d i =>
-      match n with
-      | Pmakel => Next (nextinstr (rs#d <- (Vlong i))) m
-      end
-
-  | PArithRRR n d s1 s2 =>
-      match n with
-      | Pcompw c => Next (nextinstr (rs#d <- (compare_int c rs##s1 rs##s2 m))) m
-      | Pcompl c => Next (nextinstr (rs#d <- (compare_long c rs###s1 rs###s2 m))) m
-      | Paddw  => Next (nextinstr (rs#d <- (Val.add  rs##s1 rs##s2))) m
-      | Psubw  => Next (nextinstr (rs#d <- (Val.sub  rs##s1 rs##s2))) m
-      | Pmulw  => Next (nextinstr (rs#d <- (Val.mul  rs##s1 rs##s2))) m
-      | Pandw  => Next (nextinstr (rs#d <- (Val.and  rs##s1 rs##s2))) m
-      | Porw   => Next (nextinstr (rs#d <- (Val.or   rs##s1 rs##s2))) m
-      | Pxorw  => Next (nextinstr (rs#d <- (Val.xor  rs##s1 rs##s2))) m
-      | Psrlw  => Next (nextinstr (rs#d <- (Val.shru rs##s1 rs##s2))) m
-      | Psraw  => Next (nextinstr (rs#d <- (Val.shr  rs##s1 rs##s2))) m
-      | Psllw  => Next (nextinstr (rs#d <- (Val.shl  rs##s1 rs##s2))) m
-
-      | Paddl => Next (nextinstr (rs#d <- (Val.addl rs###s1 rs###s2))) m
-      | Psubl => Next (nextinstr (rs#d <- (Val.subl rs###s1 rs###s2))) m
-      | Pandl => Next (nextinstr (rs#d <- (Val.andl rs###s1 rs###s2))) m
-      | Porl  => Next (nextinstr (rs#d <- (Val.orl  rs###s1 rs###s2))) m
-      | Pxorl  => Next (nextinstr (rs#d <- (Val.xorl  rs###s1 rs###s2))) m
-      | Pmull => Next (nextinstr (rs#d <- (Val.mull rs###s1 rs###s2))) m
-      | Pslll => Next (nextinstr (rs#d <- (Val.shll rs###s1 rs###s2))) m
-      | Psrll => Next (nextinstr (rs#d <- (Val.shrlu rs###s1 rs###s2))) m
-      | Psral => Next (nextinstr (rs#d <- (Val.shrl rs###s1 rs###s2))) m
-      end
-
-  | PArithRRI32 n d s i =>
-      match n with
-      | Pcompiw c => Next (nextinstr (rs#d <- (compare_int c rs##s (Vint i) m))) m
-      | Paddiw  => Next (nextinstr (rs#d <- (Val.add   rs##s (Vint i)))) m
-      | Pandiw  => Next (nextinstr (rs#d <- (Val.and   rs##s (Vint i)))) m
-      | Poriw   => Next (nextinstr (rs#d <- (Val.or    rs##s (Vint i)))) m
-      | Pxoriw  => Next (nextinstr (rs#d <- (Val.xor   rs##s (Vint i)))) m
-      | Psraiw  => Next (nextinstr (rs#d <- (Val.shr   rs##s (Vint i)))) m
-      | Psrliw  => Next (nextinstr (rs#d <- (Val.shru  rs##s (Vint i)))) m
-      | Pslliw  => Next (nextinstr (rs#d <- (Val.shl   rs##s (Vint i)))) m
-
-      | Psllil  => Next (nextinstr (rs#d <- (Val.shll  rs###s (Vint i)))) m
-      | Psrlil  => Next (nextinstr (rs#d <- (Val.shrlu rs###s (Vint i)))) m
-      | Psrail  => Next (nextinstr (rs#d <- (Val.shrl  rs###s (Vint i)))) m
-      end
-
-  | PArithRRI64 n d s i =>
-      match n with
-      | Pcompil c => Next (nextinstr (rs#d <- (compare_long c rs###s (Vlong i) m))) m
-      | Paddil  => Next (nextinstr (rs#d <- (Val.addl rs###s (Vlong i)))) m
-      | Pandil  => Next (nextinstr (rs#d <- (Val.andl rs###s (Vlong i)))) m
-      | Poril   => Next (nextinstr (rs#d <- (Val.orl  rs###s (Vlong i)))) m
-      | Pxoril  => Next (nextinstr (rs#d <- (Val.xorl  rs###s (Vlong i)))) m
-      end
-
-(** Loads and stores *)
-  | Plb d a ofs =>
-      exec_load Mint8signed rs m d a ofs
-  | Plbu d a ofs =>
-      exec_load Mint8unsigned rs m d a ofs
-  | Plh d a ofs =>
-      exec_load Mint16signed rs m d a ofs
-  | Plhu d a ofs =>
-      exec_load Mint16unsigned rs m d a ofs
-  | Plw d a ofs =>
-      exec_load Mint32 rs m d a ofs
-  | Plw_a d a ofs =>
-      exec_load Many32 rs m d a ofs
-  | Pld d a ofs =>
-      exec_load Mint64 rs m d a ofs
-  | Pld_a d a ofs =>
-      exec_load Many64 rs m d a ofs
-  | Psb s a ofs =>
-      exec_store Mint8unsigned rs m s a ofs
-  | Psh s a ofs =>
-      exec_store Mint16unsigned rs m s a ofs
-  | Psw s a ofs =>
-      exec_store Mint32 rs m s a ofs
-  | Psw_a s a ofs =>
-      exec_store Many32 rs m s a ofs
-  | Psd s a ofs =>
-      exec_store Mint64 rs m s a ofs
-  | Psd_a s a ofs =>
-      exec_store Many64 rs m s a ofs
-
-(** Floating point register move *)
-(*| Pfmv d s =>
-      Next (nextinstr (rs#d <- (rs#s))) m
-
-(** 32-bit (single-precision) floating point *)
-*)| Pfls d a ofs =>
-      exec_load Mfloat32 rs m d a ofs
-  | Pfss s a ofs =>
-      exec_store Mfloat32 rs m s a ofs
-
-(*| Pfnegs d s =>
-      Next (nextinstr (rs#d <- (Val.negfs rs#s))) m
-  | Pfabss d s =>
-      Next (nextinstr (rs#d <- (Val.absfs rs#s))) m
-
-  | Pfadds d s1 s2 =>
-      Next (nextinstr (rs#d <- (Val.addfs rs#s1 rs#s2))) m
-  | Pfsubs d s1 s2 =>
-      Next (nextinstr (rs#d <- (Val.subfs rs#s1 rs#s2))) m
-  | Pfmuls d s1 s2 =>
-      Next (nextinstr (rs#d <- (Val.mulfs rs#s1 rs#s2))) m
-  | Pfdivs d s1 s2 =>
-      Next (nextinstr (rs#d <- (Val.divfs rs#s1 rs#s2))) m
-  | Pfeqs d s1 s2 =>
-      Next (nextinstr (rs#d <- (Val.cmpfs Ceq rs#s1 rs#s2))) m
-  | Pflts d s1 s2 =>
-      Next (nextinstr (rs#d <- (Val.cmpfs Clt rs#s1 rs#s2))) m
-  | Pfles d s1 s2 =>
-      Next (nextinstr (rs#d <- (Val.cmpfs Cle rs#s1 rs#s2))) m
-
-  | Pfcvtws d s =>
-      Next (nextinstr (rs#d <- (Val.maketotal (Val.intofsingle rs#s)))) m
-  | Pfcvtwus d s =>
-      Next (nextinstr (rs#d <- (Val.maketotal (Val.intuofsingle rs#s)))) m
-  | Pfcvtsw d s =>
-      Next (nextinstr (rs#d <- (Val.maketotal (Val.singleofint rs##s)))) m
-  | Pfcvtswu d s =>
-      Next (nextinstr (rs#d <- (Val.maketotal (Val.singleofintu rs##s)))) m
-
-  | Pfcvtls d s =>
-      Next (nextinstr (rs#d <- (Val.maketotal (Val.longofsingle rs#s)))) m
-  | Pfcvtlus d s =>
-      Next (nextinstr (rs#d <- (Val.maketotal (Val.longuofsingle rs#s)))) m
-  | Pfcvtsl d s =>
-      Next (nextinstr (rs#d <- (Val.maketotal (Val.singleoflong rs###s)))) m
-  | Pfcvtslu d s =>
-      Next (nextinstr (rs#d <- (Val.maketotal (Val.singleoflongu rs###s)))) m
-
-(** 64-bit (double-precision) floating point *)
-*)| Pfld d a ofs =>
-      exec_load Mfloat64 rs m d a ofs
-(*| Pfld_a d a ofs =>
-      exec_load Many64 rs m d a ofs
-*)| Pfsd s a ofs =>
-      exec_store Mfloat64 rs m s a ofs
-(*| Pfsd_a s a ofs =>
-      exec_store Many64 rs m s a ofs
-
-  | Pfabsd d s =>
-      Next (nextinstr (rs#d <- (Val.absf rs#s))) m
-
-  | Pfaddd d s1 s2 =>
-      Next (nextinstr (rs#d <- (Val.addf rs#s1 rs#s2))) m
-  | Pfsubd d s1 s2 =>
-      Next (nextinstr (rs#d <- (Val.subf rs#s1 rs#s2))) m
-  | Pfmuld d s1 s2 =>
-      Next (nextinstr (rs#d <- (Val.mulf rs#s1 rs#s2))) m
-  | Pfdivd d s1 s2 =>
-      Next (nextinstr (rs#d <- (Val.divf rs#s1 rs#s2))) m
-  | Pfeqd d s1 s2 =>
-      Next (nextinstr (rs#d <- (Val.cmpf Ceq rs#s1 rs#s2))) m
-  | Pfltd d s1 s2 =>
-      Next (nextinstr (rs#d <- (Val.cmpf Clt rs#s1 rs#s2))) m
-  | Pfled d s1 s2 =>
-      Next (nextinstr (rs#d <- (Val.cmpf Cle rs#s1 rs#s2))) m
-
-  | Pfcvtwd d s =>
-      Next (nextinstr (rs#d <- (Val.maketotal (Val.intoffloat rs#s)))) m
-  | Pfcvtwud d s =>
-      Next (nextinstr (rs#d <- (Val.maketotal (Val.intuoffloat rs#s)))) m
-  | Pfcvtdw d s =>
-      Next (nextinstr (rs#d <- (Val.maketotal (Val.floatofint rs##s)))) m
-  | Pfcvtdwu d s =>
-      Next (nextinstr (rs#d <- (Val.maketotal (Val.floatofintu rs##s)))) m
-
-  | Pfcvtld d s =>
-      Next (nextinstr (rs#d <- (Val.maketotal (Val.longoffloat rs#s)))) m
-  | Pfcvtlud d s =>
-      Next (nextinstr (rs#d <- (Val.maketotal (Val.longuoffloat rs#s)))) m
-  | Pfcvtdl d s =>
-      Next (nextinstr (rs#d <- (Val.maketotal (Val.floatoflong rs###s)))) m
-  | Pfcvtdlu d s =>
-      Next (nextinstr (rs#d <- (Val.maketotal (Val.floatoflongu rs###s)))) m
-
-  | Pfcvtds d s =>
-      Next (nextinstr (rs#d <- (Val.floatofsingle rs#s))) m
-  | Pfcvtsd d s =>
-      Next (nextinstr (rs#d <- (Val.singleoffloat rs#s))) m
-
-(** Pseudo-instructions *)
-*)| Pallocframe sz pos =>
-      let (m1, stk) := Mem.alloc m 0 sz in
-      let sp := (Vptr stk Ptrofs.zero) in
-      match Mem.storev Mptr m1 (Val.offset_ptr sp pos) rs#SP with
-      | None => Stuck
-      | Some m2 => Next (nextinstr (rs #FP <- (rs SP) #SP <- sp #GPR31 <- Vundef)) m2
-      end
-  | Pfreeframe sz pos =>
-      match Mem.loadv Mptr m (Val.offset_ptr rs#SP pos) with
-      | None => Stuck
-      | Some v =>
-          match rs SP with
-          | Vptr stk ofs =>
-              match Mem.free m stk 0 sz with
-              | None => Stuck
-              | Some m' => Next (nextinstr (rs#SP <- v #GPR31 <- Vundef)) m'
-              end
-          | _ => Stuck
-          end
-      end
-  | Plabel lbl =>
-      Next (nextinstr rs) m
-  | Ploadsymbol rd s ofs =>
-      Next (nextinstr (rs#rd <- (Genv.symbol_address ge s ofs))) m
-(*| Ploadsymbol_high rd s ofs =>
-      Next (nextinstr (rs#rd <- (high_half ge s ofs))) m
-  | Ploadli rd i =>
-      Next (nextinstr (rs#GPR31 <- Vundef #rd <- (Vlong i))) m
-  | Ploadfi rd f =>
-      Next (nextinstr (rs#GPR31 <- Vundef #rd <- (Vfloat f))) m
-  | Ploadsi rd f =>
-      Next (nextinstr (rs#GPR31 <- Vundef #rd <- (Vsingle f))) m
-  | Pbtbl r tbl =>
-      match rs r with
-      | Vint n =>
-          match list_nth_z tbl (Int.unsigned n) with
-          | None => Stuck
-          | Some lbl => goto_label f lbl (rs#GPR5 <- Vundef #GPR31 <- Vundef) m
-          end
-      | _ => Stuck
-      end
-*)| Pbuiltin ef args res =>
-      Stuck (**r treated specially below *)
-
-  (** The following instructions and directives are not generated directly by Asmgen,
-      so we do not model them. *)
-    (* BCU *)
-  | Pawait
-  | Pbarrier
-  | Pdoze
-  | Pwfxl _ _
-  | Pwfxm _ _
-  | Pinvaldtlb
-  | Pinvalitlb
-  | Pprobetlb
-  | Preadtlb
-  | Psleep
-  | Pstop
-  | Psyncgroup _
-  | Ptlbwrite
-
-    (* LSU *)
-  | Pafda _ _ _
-  | Paldc _ _
-  | Pdinval
-  | Pdinvall _
-  | Pdtouchl _
-  | Pdzerol _
-  | Pfence
-  | Piinval
-  | Piinvals _
-  | Pitouchl _
-  | Plbsu _ _
-  | Plbzu _ _
-  | Pldu _ _
-  | Plhsu _ _
-  | Plhzu _ _
-  | Plwzu _ _
-
-    (* ALU *)
-  | Paddhp _ _ _
-  | Padds _ _ _
-  | Pbwlu _ _ _ _ _ _
-  | Pbwluhp _ _ _ _
-  | Pbwluwp _ _ _ _
-  | Pcbs _ _
-  | Pcbsdl _ _
-  | Pclz _ _
-  | Pclzw _ _
-  | Pclzd _ _
-  | Pclzdl _ _
-  | Pcmove _ _ _ _
-  | Pctz _ _
-  | Pctzw _ _
-  | Pctzd _ _
-  | Pctzdl _ _
-  | Pextfz _ _ _ _
-  | Plandhp _ _ _ _
-  | Psat _ _ _
-  | Psatd _ _ _
-  | Psbfhp _ _ _
-  | Psbmm8 _ _ _
-  | Psbmmt8 _ _ _
-  | Psllhps _ _ _
-  | Psrahps _ _ _
-  | Pstsu _ _ _
-  | Pstsud _ _ _
-
-    => Stuck
-  end.
-
-(** Translation of the LTL/Linear/Mach view of machine registers to
-  the RISC-V view.  Note that no LTL register maps to [X31].  This
-  register is reserved as temporary, to be used by the generated RV32G
-  code.  *)
-
-  (* FIXME - R31 is not there *)
-Definition preg_of (r: mreg) : preg :=
-  match r with
-  | R0  => GPR0  | R1  => GPR1  | R2  => GPR2  | R3  => GPR3  | R4  => GPR4
-  | R5  => GPR5  | R6  => GPR6  | R7  => GPR7                 | R9  => GPR9
-  | R10 => GPR10 (*| R11 => GPR11 | R12 => GPR12 | R13 => GPR13 | R14  => GPR14 *)
-  | R15 => GPR15 | R16 => GPR16 | R17 => GPR17 | R18 => GPR18 | R19  => GPR19
-  | R20 => GPR20 | R21 => GPR21 | R22 => GPR22 | R23 => GPR23 | R24  => GPR24
-  | R25 => GPR25 | R26 => GPR26 | R27 => GPR27 | R28 => GPR28 | R29  => GPR29
-  | R30 => GPR30 |                R32 => GPR32 | R33 => GPR33 | R34  => GPR34
-  | R35 => GPR35 | R36 => GPR36 | R37 => GPR37 | R38 => GPR38 | R39  => GPR39
-  | R40 => GPR40 | R41 => GPR41 | R42 => GPR42 | R43 => GPR43 | R44  => GPR44
-  | R45 => GPR45 | R46 => GPR46 | R47 => GPR47 | R48 => GPR48 | R49  => GPR49
-  | R50 => GPR50 | R51 => GPR51 | R52 => GPR52 | R53 => GPR53 | R54  => GPR54
-  | R55 => GPR55 | R56 => GPR56 | R57 => GPR57 | R58 => GPR58 | R59  => GPR59
-  | R60 => GPR60 | R61 => GPR61 | R62 => GPR62 | R63 => GPR63
-  end.
-
-(** Extract the values of the arguments of an external call.
-    We exploit the calling conventions from module [Conventions], except that
-    we use RISC-V registers instead of locations. *)
-
-Inductive extcall_arg (rs: regset) (m: mem): loc -> val -> Prop :=
-  | extcall_arg_reg: forall r,
-      extcall_arg rs m (R r) (rs (preg_of r))
-  | extcall_arg_stack: forall ofs ty bofs v,
-      bofs = Stacklayout.fe_ofs_arg + 4 * ofs ->
-      Mem.loadv (chunk_of_type ty) m
-                (Val.offset_ptr rs#SP (Ptrofs.repr bofs)) = Some v ->
-      extcall_arg rs m (S Outgoing ofs ty) v.
-
-Inductive extcall_arg_pair (rs: regset) (m: mem): rpair loc -> val -> Prop :=
-  | extcall_arg_one: forall l v,
-      extcall_arg rs m l v ->
-      extcall_arg_pair rs m (One l) v
-  | extcall_arg_twolong: forall hi lo vhi vlo,
-      extcall_arg rs m hi vhi ->
-      extcall_arg rs m lo vlo ->
-      extcall_arg_pair rs m (Twolong hi lo) (Val.longofwords vhi vlo).
-
-Definition extcall_arguments
-    (rs: regset) (m: mem) (sg: signature) (args: list val) : Prop :=
-  list_forall2 (extcall_arg_pair rs m) (loc_arguments sg) args.
-
-Definition loc_external_result (sg: signature) : rpair preg :=
-  map_rpair preg_of (loc_result sg).
-
-(** Execution of the instruction at [rs PC]. *)
-
-Inductive state: Type :=
-  | State: regset -> mem -> state.
-
-Inductive step: state -> trace -> state -> Prop :=
-  | exec_step_internal:
-      forall b ofs f i rs m rs' m',
-      rs PC = Vptr b ofs ->
-      Genv.find_funct_ptr ge b = Some (Internal f) ->
-      find_instr (Ptrofs.unsigned ofs) (fn_code f) = Some i ->
-      exec_instr f i rs m = Next rs' m' ->
-      step (State rs m) E0 (State rs' m')
-  | exec_step_builtin:
-      forall b ofs f ef args res rs m vargs t vres rs' m',
-      rs PC = Vptr b ofs ->
-      Genv.find_funct_ptr ge b = Some (Internal f) ->
-      find_instr (Ptrofs.unsigned ofs) f.(fn_code) = Some (A:=instruction) (Pbuiltin ef args res) ->
-      eval_builtin_args ge rs (rs SP) m args vargs ->
-      external_call ef ge vargs m t vres m' ->
-      rs' = nextinstr
-              (set_res res vres
-                (undef_regs (map preg_of (destroyed_by_builtin ef))
-                   (rs#GPR31 <- Vundef))) ->
-      step (State rs m) t (State rs' m')
-  | exec_step_external:
-      forall b ef args res rs m t rs' m',
-      rs PC = Vptr b Ptrofs.zero ->
-      Genv.find_funct_ptr ge b = Some (External ef) ->
-      external_call ef ge args m t res m' ->
-      extcall_arguments rs m (ef_sig ef) args ->
-      rs' = (set_pair (loc_external_result (ef_sig ef) ) res rs)#PC <- (rs RA) ->
-      step (State rs m) t (State rs' m').
-
-End RELSEM.
-
-(** Execution of whole programs. *)
-
-Inductive initial_state (p: program): state -> Prop :=
-  | initial_state_intro: forall m0,
-      let ge := Genv.globalenv p in
-      let rs0 :=
-        (Pregmap.init Vundef)
-        # PC <- (Genv.symbol_address ge p.(prog_main) Ptrofs.zero)
-        # SP <- Vnullptr
-        # RA <- Vnullptr in
-      Genv.init_mem p = Some m0 ->
-      initial_state p (State rs0 m0).
-
-Inductive final_state: state -> int -> Prop :=
-  | final_state_intro: forall rs m r,
-      rs PC = Vnullptr ->
-      rs GPR0 = Vint r ->
-      final_state (State rs m) r.
-
-Definition semantics (p: program) :=
-  Semantics step (initial_state p) final_state (Genv.globalenv p).
-
-(** Determinacy of the [Asm] semantics. *)
-
-Remark extcall_arguments_determ:
-  forall rs m sg args1 args2,
-  extcall_arguments rs m sg args1 -> extcall_arguments rs m sg args2 -> args1 = args2.
-Proof.
-  intros until m.
-  assert (A: forall l v1 v2,
-             extcall_arg rs m l v1 -> extcall_arg rs m l v2 -> v1 = v2).
-  { intros. inv H; inv H0; congruence. }
-  assert (B: forall p v1 v2,
-             extcall_arg_pair rs m p v1 -> extcall_arg_pair rs m p v2 -> v1 = v2).
-  { intros. inv H; inv H0. 
-    eapply A; eauto.
-    f_equal; eapply A; eauto. }
-  assert (C: forall ll vl1, list_forall2 (extcall_arg_pair rs m) ll vl1 ->
-             forall vl2, list_forall2 (extcall_arg_pair rs m) ll vl2 -> vl1 = vl2).
-  {
-    induction 1; intros vl2 EA; inv EA.
-    auto.
-    f_equal; eauto. }
-  intros. eapply C; eauto.
-Qed.
-
-Lemma semantics_determinate: forall p, determinate (semantics p).
-Proof.
-Ltac Equalities :=
-  match goal with
-  | [ H1: ?a = ?b, H2: ?a = ?c |- _ ] =>
-      rewrite H1 in H2; inv H2; Equalities
-  | _ => idtac
-  end.
-  intros; constructor; simpl; intros.
-- (* determ *)
-  inv H; inv H0; Equalities.
-  split. constructor. auto.
-  discriminate.
-  discriminate.
-  assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0.
-  exploit external_call_determ. eexact H5. eexact H11. intros [A B].
-  split. auto. intros. destruct B; auto. subst. auto.
-  assert (args0 = args) by (eapply extcall_arguments_determ; eauto). subst args0.
-  exploit external_call_determ. eexact H3. eexact H8. intros [A B].
-  split. auto. intros. destruct B; auto. subst. auto.
-- (* trace length *)
-  red; intros. inv H; simpl.
-  omega.
-  eapply external_call_trace_length; eauto.
-  eapply external_call_trace_length; eauto.
-- (* initial states *)
-  inv H; inv H0. f_equal. congruence.
-- (* final no step *)
-  assert (NOTNULL: forall b ofs, Vnullptr <> Vptr b ofs).
-  { intros; unfold Vnullptr; destruct Archi.ptr64; congruence. }
-  inv H. unfold Vzero in H0. red; intros; red; intros.
-  inv H; rewrite H0 in *; eelim NOTNULL; eauto.
-- (* final states *)
-  inv H; inv H0. congruence.
-Qed.
-
-(** Classification functions for processor registers (used in Asmgenproof). *)
-
-Definition data_preg (r: preg) : bool :=
-  match r with
-  | RA  => false
-  | IR GPR31 => false
-  | IR GPR8 => false
-  | IR _   => true
-  | FR _   => true
-  | PC     => false
-  end.
+(* *********************************************************************)

+(*                                                                     *)

+(*              The Compcert verified compiler                         *)

+(*                                                                     *)

+(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)

+(*           Prashanth Mundkur, SRI International                      *)

+(*                                                                     *)

+(*  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.     *)

+(*                                                                     *)

+(*  The contributions by Prashanth Mundkur are reused and adapted      *)

+(*  under the terms of a Contributor License Agreement between         *)

+(*  SRI International and INRIA.                                       *)

+(*                                                                     *)

+(* *********************************************************************)

+

+(** Abstract syntax and semantics for K1c assembly language. *)

+

+Require Import Coqlib.

+Require Import Maps.

+Require Import AST.

+Require Import Integers.

+Require Import Floats.

+Require Import Values.

+Require Import Memory.

+Require Import Events.

+Require Import Globalenvs.

+Require Import Smallstep.

+Require Import Locations.

+Require Stacklayout.

+Require Import Conventions.

+Require Import Asmblock.

+Require Import Linking.

+Require Import Errors.

+

+(** Definitions for OCaml code *)

+Definition label := positive.

+Definition preg := preg.

+

+(** Syntax *)

+Inductive instruction : Type :=

+  (** pseudo instructions *)

+  | Pallocframe (sz: Z) (pos: ptrofs)               (**r allocate new stack frame *)

+  | Pfreeframe  (sz: Z) (pos: ptrofs)               (**r deallocate stack frame and restore previous frame *)

+  | Plabel  (lbl: label)                            (**r define a code label *)

+  | Ploadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the address of a symbol *)

+  | Pbuiltin: external_function -> list (builtin_arg preg)

+              -> builtin_res preg -> instruction   (**r built-in function (pseudo) *)

+  | Pnop                                            (**r instruction that does nothing *)

+

+  (** builtins *)

+  | Pclzll (rd rs: ireg)

+  | Pstsud (rd rs1 rs2: ireg)

+

+  (** Control flow instructions *)

+  | Pget    (rd: ireg) (rs: preg)                   (**r get system register *)

+  | Pset    (rd: preg) (rs: ireg)                   (**r set system register *)

+  | Pret                                            (**r return *)

+  | Pcall   (l: label)                              (**r function call *)

+  (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *)

+  | Pgoto   (l: label)                              (**r goto *)

+  | Pj_l    (l: label)                              (**r jump to label *)

+  | Pcb     (bt: btest) (r: ireg) (l: label)        (**r branch based on btest *)

+  | Pcbu    (bt: btest) (r: ireg) (l: label)        (**r branch based on btest with unsigned semantics *)

+

+  (** Loads **)

+  | Plb     (rd: ireg) (ra: ireg) (ofs: offset)     (**r load byte *)

+  | Plbu    (rd: ireg) (ra: ireg) (ofs: offset)     (**r load byte unsigned *)

+  | Plh     (rd: ireg) (ra: ireg) (ofs: offset)     (**r load half word *)

+  | Plhu    (rd: ireg) (ra: ireg) (ofs: offset)     (**r load half word unsigned *)

+  | Plw     (rd: ireg) (ra: ireg) (ofs: offset)     (**r load int32 *)

+  | Plw_a   (rd: ireg) (ra: ireg) (ofs: offset)     (**r load any32 *)

+  | Pld     (rd: ireg) (ra: ireg) (ofs: offset)     (**r load int64 *)

+  | Pld_a   (rd: ireg) (ra: ireg) (ofs: offset)     (**r load any64 *)

+  | Pfls    (rd: freg) (ra: ireg) (ofs: offset)     (**r load float *)

+  | Pfld     (rd: freg) (ra: ireg) (ofs: offset)    (**r load 64-bit float *)

+

+  (** Stores **)

+  | Psb     (rs: ireg) (ra: ireg) (ofs: offset)     (**r store byte *)

+  | Psh     (rs: ireg) (ra: ireg) (ofs: offset)     (**r store half byte *)

+  | Psw     (rs: ireg) (ra: ireg) (ofs: offset)     (**r store int32 *)

+  | Psw_a   (rs: ireg) (ra: ireg) (ofs: offset)     (**r store any32 *)

+  | Psd     (rs: ireg) (ra: ireg) (ofs: offset)     (**r store int64 *)

+  | Psd_a   (rs: ireg) (ra: ireg) (ofs: offset)     (**r store any64 *)

+  | Pfss    (rs: freg) (ra: ireg) (ofs: offset)     (**r store float *)

+  | Pfsd     (rd: freg) (ra: ireg) (ofs: offset)    (**r store 64-bit float *)

+

+  (** Arith R *)

+  | Pcvtw2l (rd: ireg)                              (**r Convert Word to Long *)

+

+  (** Arith RR *)

+  | Pmv     (rd rs: ireg)                           (**r register move *)

+  | Pnegw   (rd rs: ireg)                           (**r negate word *)

+  | Pnegl   (rd rs: ireg)                           (**r negate long *)

+  | Pfnegd  (rd rs: ireg)                           (**r float negate double *)

+  | Pcvtl2w (rd rs: ireg)                           (**r Convert Long to Word *)

+  | Pmvw2l  (rd rs: ireg)                           (**r Move Convert Word to Long *)

+

+  (** Arith RI32 *)

+  | Pmake   (rd: ireg) (imm: int)                   (**r load immediate *)

+

+  (** Arith RI64 *)

+  | Pmakel  (rd: ireg) (imm: int64)                 (**r load immediate long *)

+

+  (** Arith RRR *)

+  | Pcompw  (it: itest) (rd rs1 rs2: ireg)          (**r comparison word *)

+  | Pcompl  (it: itest) (rd rs1 rs2: ireg)          (**r comparison long *)

+

+  | Paddw               (rd rs1 rs2: ireg)          (**r add word *)

+  | Psubw               (rd rs1 rs2: ireg)          (**r sub word *)

+  | Pmulw               (rd rs1 rs2: ireg)          (**r mul word *)

+  | Pandw               (rd rs1 rs2: ireg)          (**r and word *)

+  | Porw                (rd rs1 rs2: ireg)          (**r or word *)

+  | Pxorw               (rd rs1 rs2: ireg)          (**r xor word *)

+  | Psraw               (rd rs1 rs2: ireg)          (**r shift right arithmetic word *)

+  | Psrlw               (rd rs1 rs2: ireg)          (**r shift right logical word *)

+  | Psllw               (rd rs1 rs2: ireg)          (**r shift left logical word *)

+

+  | Paddl               (rd rs1 rs2: ireg)          (**r add long *)

+  | Psubl               (rd rs1 rs2: ireg)          (**r sub long *)

+  | Pandl               (rd rs1 rs2: ireg)          (**r and long *)

+  | Porl                (rd rs1 rs2: ireg)          (**r or long *)

+  | Pxorl               (rd rs1 rs2: ireg)          (**r xor long *)

+  | Pmull               (rd rs1 rs2: ireg)          (**r mul long (low part) *)

+  | Pslll               (rd rs1 rs2: ireg)          (**r shift left logical long *)

+  | Psrll               (rd rs1 rs2: ireg)          (**r shift right logical long *)

+  | Psral               (rd rs1 rs2: ireg)          (**r shift right arithmetic long *)

+

+  (** Arith RRI32 *)

+  | Pcompiw (it: itest) (rd rs: ireg) (imm: int)    (**r comparison imm word *)

+

+  | Paddiw              (rd rs: ireg) (imm: int)    (**r add imm word *)

+  | Pandiw              (rd rs: ireg) (imm: int)    (**r and imm word *)

+  | Poriw               (rd rs: ireg) (imm: int)    (**r or imm word *)

+  | Pxoriw              (rd rs: ireg) (imm: int)    (**r xor imm word *)

+  | Psraiw              (rd rs: ireg) (imm: int)    (**r shift right arithmetic imm word *)

+  | Psrliw              (rd rs: ireg) (imm: int)    (**r shift right logical imm word *)

+  | Pslliw              (rd rs: ireg) (imm: int)    (**r shift left logical imm word *)

+

+  | Psllil              (rd rs: ireg) (imm: int)    (**r shift left logical immediate long *)

+  | Psrlil              (rd rs: ireg) (imm: int)    (**r shift right logical immediate long *)

+  | Psrail              (rd rs: ireg) (imm: int)    (**r shift right arithmetic immediate long *)

+

+  (** Arith RRI64 *)

+  | Pcompil (it: itest) (rd rs: ireg) (imm: int64)  (**r comparison imm long *)

+  | Paddil              (rd rs: ireg) (imm: int64)  (**r add immediate long *) 

+  | Pandil              (rd rs: ireg) (imm: int64)  (**r and immediate long *) 

+  | Poril               (rd rs: ireg) (imm: int64)  (**r or immediate long *) 

+  | Pxoril              (rd rs: ireg) (imm: int64)  (**r xor immediate long *) 

+  .

+

+(** Correspondance between Asmblock and Asm *)

+

+Definition control_to_instruction (c: control) :=

+  match c with

+  | PExpand (Asmblock.Pbuiltin ef args res) => Pbuiltin ef args res

+  | PCtlFlow Asmblock.Pret                  => Pret

+  | PCtlFlow (Asmblock.Pcall l)             => Pcall l

+  | PCtlFlow (Asmblock.Pgoto l)             => Pgoto l

+  | PCtlFlow (Asmblock.Pj_l l)              => Pj_l l

+  | PCtlFlow (Asmblock.Pcb bt r l)          => Pcb bt r l

+  | PCtlFlow (Asmblock.Pcbu bt r l)         => Pcbu bt r l

+  end.

+

+Definition basic_to_instruction (b: basic) :=

+  match b with

+  (** Special basics *)

+  | Asmblock.Pget rd rs         => Pget rd rs

+  | Asmblock.Pset rd rs         => Pset rd rs

+  | Asmblock.Pnop               => Pnop

+  | Asmblock.Pallocframe sz pos => Pallocframe sz pos

+  | Asmblock.Pfreeframe sz pos  => Pfreeframe sz pos

+

+  (** PArith basics *)

+  (* R *)

+  | PArithR Asmblock.Pcvtw2l r              => Pcvtw2l r

+  | PArithR (Asmblock.Ploadsymbol id ofs) r => Ploadsymbol r id ofs

+

+  (* RR *)

+  | PArithRR Asmblock.Pmv rd rs     => Pmv rd rs

+  | PArithRR Asmblock.Pnegw rd rs   => Pnegw rd rs

+  | PArithRR Asmblock.Pnegl rd rs   => Pfnegd rd rs

+  | PArithRR Asmblock.Pcvtl2w rd rs => Pcvtl2w rd rs

+  | PArithRR Asmblock.Pmvw2l rd rs  => Pmvw2l rd rs

+  | PArithRR Asmblock.Pfnegd rd rs  => Pfnegd rd rs

+

+  (* RI32 *)

+  | PArithRI32 Asmblock.Pmake rd imm  => Pmake rd imm

+

+  (* RI64 *)

+  | PArithRI64 Asmblock.Pmakel rd imm => Pmakel rd imm

+

+  (* RRR *)

+  | PArithRRR (Asmblock.Pcompw it) rd rs1 rs2 => Pcompw it rd rs1 rs2

+  | PArithRRR (Asmblock.Pcompl it) rd rs1 rs2 => Pcompl it rd rs1 rs2

+  | PArithRRR Asmblock.Paddw rd rs1 rs2       => Paddw rd rs1 rs2

+  | PArithRRR Asmblock.Psubw rd rs1 rs2       => Psubw rd rs1 rs2

+  | PArithRRR Asmblock.Pmulw rd rs1 rs2       => Pmulw rd rs1 rs2

+  | PArithRRR Asmblock.Pandw rd rs1 rs2       => Pandw rd rs1 rs2

+  | PArithRRR Asmblock.Porw rd rs1 rs2        => Porw rd rs1 rs2

+  | PArithRRR Asmblock.Pxorw rd rs1 rs2       => Pxorw rd rs1 rs2

+  | PArithRRR Asmblock.Psraw rd rs1 rs2       => Psraw rd rs1 rs2

+  | PArithRRR Asmblock.Psrlw rd rs1 rs2       => Psrlw rd rs1 rs2

+  | PArithRRR Asmblock.Psllw rd rs1 rs2       => Psllw rd rs1 rs2

+

+  | PArithRRR Asmblock.Paddl rd rs1 rs2       => Paddl rd rs1 rs2

+  | PArithRRR Asmblock.Psubl rd rs1 rs2       => Psubl rd rs1 rs2

+  | PArithRRR Asmblock.Pandl rd rs1 rs2       => Pandl rd rs1 rs2

+  | PArithRRR Asmblock.Porl rd rs1 rs2        => Porl rd rs1 rs2

+  | PArithRRR Asmblock.Pxorl rd rs1 rs2       => Pxorl rd rs1 rs2

+  | PArithRRR Asmblock.Pmull rd rs1 rs2       => Pmull rd rs1 rs2

+  | PArithRRR Asmblock.Pslll rd rs1 rs2       => Pslll rd rs1 rs2

+  | PArithRRR Asmblock.Psrll rd rs1 rs2       => Psrll rd rs1 rs2

+  | PArithRRR Asmblock.Psral rd rs1 rs2       => Psral rd rs1 rs2

+

+  (* RRI32 *)

+  | PArithRRI32 (Asmblock.Pcompiw it) rd rs imm => Pcompiw it rd rs imm

+  | PArithRRI32 Asmblock.Paddiw rd rs imm       => Paddiw rd rs imm

+  | PArithRRI32 Asmblock.Pandiw rd rs imm       => Pandiw rd rs imm

+  | PArithRRI32 Asmblock.Poriw rd rs imm        => Poriw rd rs imm

+  | PArithRRI32 Asmblock.Pxoriw rd rs imm       => Pxoriw rd rs imm

+  | PArithRRI32 Asmblock.Psraiw rd rs imm       => Psraiw rd rs imm

+  | PArithRRI32 Asmblock.Psrliw rd rs imm       => Psrliw rd rs imm

+  | PArithRRI32 Asmblock.Pslliw rd rs imm       => Pslliw rd rs imm

+  | PArithRRI32 Asmblock.Psllil rd rs imm       => Psllil rd rs imm

+  | PArithRRI32 Asmblock.Psrlil rd rs imm       => Psrlil rd rs imm

+  | PArithRRI32 Asmblock.Psrail rd rs imm       => Psrail rd rs imm

+

+  (* RRI64 *)

+  | PArithRRI64 (Asmblock.Pcompil it) rd rs imm => Pcompil it rd rs imm

+  | PArithRRI64 Asmblock.Paddil rd rs imm       => Paddil rd rs imm

+  | PArithRRI64 Asmblock.Pandil rd rs imm       => Pandil rd rs imm

+  | PArithRRI64 Asmblock.Poril rd rs imm        => Poril rd rs imm

+  | PArithRRI64 Asmblock.Pxoril rd rs imm       => Pxoril rd rs imm

+

+  (** Load *)

+  | PLoadRRO Asmblock.Plb rd ra ofs   => Plb rd ra ofs

+  | PLoadRRO Asmblock.Plbu rd ra ofs  => Plbu rd ra ofs

+  | PLoadRRO Asmblock.Plh rd ra ofs   => Plh rd ra ofs

+  | PLoadRRO Asmblock.Plhu rd ra ofs  => Plhu rd ra ofs

+  | PLoadRRO Asmblock.Plw rd ra ofs   => Plw rd ra ofs

+  | PLoadRRO Asmblock.Plw_a rd ra ofs => Plw_a rd ra ofs

+  | PLoadRRO Asmblock.Pld rd ra ofs   => Pld rd ra ofs

+  | PLoadRRO Asmblock.Pld_a rd ra ofs => Pld_a rd ra ofs

+  | PLoadRRO Asmblock.Pfls rd ra ofs  => Pfls rd ra ofs

+  | PLoadRRO Asmblock.Pfld rd ra ofs  => Pfld rd ra ofs

+

+  (** Store *)

+  | PStoreRRO Asmblock.Psb rd ra ofs  => Psb rd ra ofs

+  | PStoreRRO Asmblock.Psh rd ra ofs => Psh rd ra ofs

+  | PStoreRRO Asmblock.Psw rd ra ofs => Psw rd ra ofs

+  | PStoreRRO Asmblock.Psw_a rd ra ofs => Psw_a rd ra ofs

+  | PStoreRRO Asmblock.Psd rd ra ofs => Psd rd ra ofs

+  | PStoreRRO Asmblock.Psd_a rd ra ofs => Psd_a rd ra ofs

+  | PStoreRRO Asmblock.Pfss rd ra ofs => Pfss rd ra ofs

+  | PStoreRRO Asmblock.Pfsd rd ra ofs => Pfss rd ra ofs

+

+  end.

+

+Section RELSEM.

+

+Definition code := list instruction.

+

+Fixpoint unfold_label (ll: list label) :=

+  match ll with

+  | nil => nil

+  | l :: ll => Plabel l :: unfold_label ll

+  end.

+

+Fixpoint unfold_body (lb: list basic) :=

+  match lb with

+  | nil => nil

+  | b :: lb => basic_to_instruction b :: unfold_body lb

+  end.

+

+Definition unfold_exit (oc: option control) :=

+  match oc with

+  | None => nil

+  | Some c => control_to_instruction c :: nil

+  end.

+

+Definition unfold_bblock (b: bblock) := unfold_label (header b) ++ unfold_body (body b) ++ unfold_exit (exit b).

+

+Fixpoint unfold (lb: bblocks) :=

+  match lb with

+  | nil => nil

+  | b :: lb => (unfold_bblock b) ++ unfold lb

+  end.

+

+Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks; fn_code: code; 

+                                       correct: unfold fn_blocks = fn_code }.

+

+(* For OCaml code *)

+Program Definition dummy_function := {| fn_code := nil; fn_sig := signature_main; fn_blocks := nil |}.

+

+Definition fundef := AST.fundef function.

+Definition program := AST.program fundef unit.

+Definition genv := Genv.t fundef unit.

+

+Definition function_proj (f: function) := Asmblock.mkfunction (fn_sig f) (fn_blocks f).

+

+(* 

+Definition fundef_proj (fu: fundef) : Asmblock.fundef := transf_fundef function_proj fu.

+

+Definition program_proj (p: program) : Asmblock.program := transform_program fundef_proj p.

+ *)

+

+Definition fundef_proj (fu: fundef) : Asmblock.fundef := 

+  match fu with

+  | Internal f => Internal (function_proj f)

+  | External ef => External ef

+  end.

+

+Definition globdef_proj (gd: globdef fundef unit) : globdef Asmblock.fundef unit :=

+  match gd with

+  | Gfun f => Gfun (fundef_proj f)

+  | Gvar gu => Gvar gu

+  end.

+

+Program Definition genv_trans (ge: genv) : Asmblock.genv :=

+  {|  Genv.genv_public := Genv.genv_public ge;

+      Genv.genv_symb := Genv.genv_symb ge;

+      Genv.genv_defs := PTree.map1 globdef_proj (Genv.genv_defs ge);

+      Genv.genv_next := Genv.genv_next ge |}.

+Next Obligation.

+  destruct ge. simpl in *. eauto.

+Qed. Next Obligation.

+  destruct ge; simpl in *.

+  rewrite PTree.gmap1 in H.

+  destruct (genv_defs ! b) eqn:GEN.

+  - eauto.

+  - discriminate.

+Qed. Next Obligation.

+  destruct ge; simpl in *.

+  eauto.

+Qed.

+

+Fixpoint prog_defs_proj (l: list (ident * globdef fundef unit))

+                          : list (ident * globdef Asmblock.fundef unit) :=

+  match l with

+  | nil => nil

+  | (i, gd) :: l => (i, globdef_proj gd) :: prog_defs_proj l

+  end.

+

+Definition program_proj (p: program) : Asmblock.program :=

+  {|  prog_defs := prog_defs_proj (prog_defs p);

+      prog_public := prog_public p;

+      prog_main := prog_main p

+  |}.

+

+End RELSEM.

+

+Definition semantics (p: program) := Asmblock.semantics (program_proj p).

+

+(** Determinacy of the [Asm] semantics. *)

+

+Lemma semantics_determinate: forall p, determinate (semantics p).

+Proof.

+  intros. apply semantics_determinate.

+Qed.

+

+(** transf_program *)

+

+Program Definition transf_function (f: Asmblock.function) : function :=

+     {| fn_sig := Asmblock.fn_sig f; fn_blocks := Asmblock.fn_blocks f; 

+        fn_code := unfold (Asmblock.fn_blocks f) |}.

+

+Lemma transf_function_proj: forall f, function_proj (transf_function f) = f.

+Proof.

+  intros f. destruct f as [sig blks]. unfold function_proj. simpl. auto.

+Qed.

+

+Definition transf_fundef : Asmblock.fundef -> fundef := AST.transf_fundef transf_function.

+

+Lemma transf_fundef_proj: forall f, fundef_proj (transf_fundef f) = f.

+Proof.

+  intros f. destruct f as [f|e]; simpl; auto.

+  rewrite transf_function_proj. auto.

+Qed.

+

+(* Definition transf_globdef (gd: globdef Asmblock.fundef unit) : globdef fundef unit :=

+  match gd with

+  | Gfun f => Gfun (transf_fundef f)

+  | Gvar gu => Gvar gu

+  end.

+

+Lemma transf_globdef_proj: forall gd, globdef_proj (transf_globdef gd) = gd.

+Proof.

+  intros gd. destruct gd as [f|v]; simpl; auto.

+  rewrite transf_fundef_proj; auto.

+Qed.

+

+Fixpoint transf_prog_defs (l: list (ident * globdef Asmblock.fundef unit))

+                            : list (ident * globdef fundef unit) :=

+  match l with

+  | nil => nil

+  | (i, gd) :: l => (i, transf_globdef gd) :: transf_prog_defs l

+  end.

+

+Lemma transf_prog_proj: forall p, prog_defs p = prog_defs_proj (transf_prog_defs (prog_defs p)).

+Proof.

+  intros p. destruct p as [defs pub main]. simpl.

+  induction defs; simpl; auto.

+  destruct a as [i gd]. simpl.

+  rewrite transf_globdef_proj.

+  congruence.

+Qed.

+ *)

+

+Definition transf_program : Asmblock.program -> program := transform_program transf_fundef.

+

+Lemma program_equals {A B: Type} : forall (p1 p2: AST.program A B),

+  prog_defs p1 = prog_defs p2 ->

+  prog_public p1 = prog_public p2 ->

+  prog_main p1 = prog_main p2 ->

+  p1 = p2.

+Proof.

+  intros. destruct p1. destruct p2. simpl in *. subst. auto.

+Qed.

+

+Lemma transf_program_proj: forall p, program_proj (transf_program p) = p.

+Proof.

+  intros p. destruct p as [defs pub main]. unfold program_proj. simpl.

+  apply program_equals; simpl; auto.

+  induction defs.

+  - simpl; auto.

+  - simpl. rewrite IHdefs. 

+    destruct a as [id gd]; simpl.

+    destruct gd as [f|v]; simpl; auto.

+    rewrite transf_fundef_proj. auto.

+Qed.

+

+Definition match_prog (p: Asmblock.program) (tp: program) :=

+  match_program (fun _ f tf => tf = transf_fundef f) eq p tp.

+

+Lemma transf_program_match:

+  forall p tp, transf_program p = tp -> match_prog p tp.

+Proof.

+  intros. rewrite <- H. eapply match_transform_program; eauto.

+Qed.

+

+Lemma cons_extract {A: Type} : forall (l: list A) a b, a = b -> a::l = b::l.

+Proof.

+  intros. congruence.

+Qed.

+

+(* I think it is a special case of Asmblock -> Asm. Very handy to have *)

+Lemma match_program_transf:

+  forall p tp, match_prog p tp -> transf_program p = tp.

+Proof.

+  intros p tp H. inversion_clear H. inv H1.

+  destruct p as [defs pub main]. destruct tp as [tdefs tpub tmain]. simpl in *.

+  subst. unfold transf_program. unfold transform_program. simpl.

+  apply program_equals; simpl; auto.

+  induction H0; simpl; auto.

+  rewrite IHlist_forall2. apply cons_extract.

+  destruct a1 as [ida gda]. destruct b1 as [idb gdb].

+  simpl in *.

+  inv H. inv H2.

+  - simpl in *. subst. auto.

+  - simpl in *. subst. inv H. auto.

+Qed.

+

+Section PRESERVATION.

+

+Variable prog: Asmblock.program.

+Variable tprog: program.

+Hypothesis TRANSF: match_prog prog tprog.

+Let ge := Genv.globalenv prog.

+Let tge := Genv.globalenv tprog.

+

+Definition match_states (s1 s2: state) := s1 = s2.

+

+Lemma symbols_preserved:

+  forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.

+Proof (Genv.find_symbol_match TRANSF).

+

+Lemma senv_preserved:

+  Senv.equiv ge tge.

+Proof (Genv.senv_match TRANSF).

+

+

+Theorem transf_program_correct:

+  forward_simulation (Asmblock.semantics prog) (semantics tprog).

+Proof.

+  pose proof (match_program_transf prog tprog TRANSF) as TR.

+  subst. unfold semantics. rewrite transf_program_proj.

+

+  eapply forward_simulation_step with (match_states := match_states); simpl; auto.

+  - intros. exists s1. split; auto. congruence.

+  - intros. inv H. auto.

+  - intros. exists s1'. inv H0. split; auto. congruence.

+Qed.

+

+End PRESERVATION.

diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v
new file mode 100644
index 00000000..557ab788
--- /dev/null
+++ b/mppa_k1c/Asmblock.v
@@ -0,0 +1,1361 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              The Compcert verified compiler                         *)
+(*                                                                     *)
+(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
+(*           Prashanth Mundkur, SRI International                      *)
+(*                                                                     *)
+(*  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.     *)
+(*                                                                     *)
+(*  The contributions by Prashanth Mundkur are reused and adapted      *)
+(*  under the terms of a Contributor License Agreement between         *)
+(*  SRI International and INRIA.                                       *)
+(*                                                                     *)
+(* *********************************************************************)
+
+(** Abstract syntax and semantics for K1c assembly language. *)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Memory.
+Require Import Events.
+Require Import Globalenvs.
+Require Import Smallstep.
+Require Import Locations.
+Require Stacklayout.
+Require Import Conventions.
+
+(** * Abstract syntax *)
+
+(** General Purpose registers.
+*)
+
+Inductive gpreg: Type :=
+  | GPR0:  gpreg | GPR1:  gpreg | GPR2:  gpreg | GPR3:  gpreg | GPR4:  gpreg
+  | GPR5:  gpreg | GPR6:  gpreg | GPR7:  gpreg | GPR8:  gpreg | GPR9:  gpreg
+  | GPR10: gpreg | GPR11: gpreg | GPR12: gpreg | GPR13: gpreg | GPR14: gpreg
+  | GPR15: gpreg | GPR16: gpreg | GPR17: gpreg | GPR18: gpreg | GPR19: gpreg
+  | GPR20: gpreg | GPR21: gpreg | GPR22: gpreg | GPR23: gpreg | GPR24: gpreg
+  | GPR25: gpreg | GPR26: gpreg | GPR27: gpreg | GPR28: gpreg | GPR29: gpreg
+  | GPR30: gpreg | GPR31: gpreg | GPR32: gpreg | GPR33: gpreg | GPR34: gpreg
+  | GPR35: gpreg | GPR36: gpreg | GPR37: gpreg | GPR38: gpreg | GPR39: gpreg
+  | GPR40: gpreg | GPR41: gpreg | GPR42: gpreg | GPR43: gpreg | GPR44: gpreg
+  | GPR45: gpreg | GPR46: gpreg | GPR47: gpreg | GPR48: gpreg | GPR49: gpreg
+  | GPR50: gpreg | GPR51: gpreg | GPR52: gpreg | GPR53: gpreg | GPR54: gpreg
+  | GPR55: gpreg | GPR56: gpreg | GPR57: gpreg | GPR58: gpreg | GPR59: gpreg
+  | GPR60: gpreg | GPR61: gpreg | GPR62: gpreg | GPR63: gpreg.
+
+Definition ireg := gpreg.
+Definition freg := gpreg.
+
+Lemma ireg_eq: forall (x y: ireg), {x=y} + {x<>y}.
+Proof. decide equality. Defined.
+
+Lemma freg_eq: forall (x y: freg), {x=y} + {x<>y}.
+Proof. decide equality. Defined.
+
+(** We model the following registers of the RISC-V architecture. *)
+
+(** basic register *)
+Inductive preg: Type :=
+  | IR: gpreg -> preg                   (**r integer registers *)
+  | FR: gpreg -> preg                   (**r float registers   *)
+  | RA: preg
+  | PC: preg
+  .
+
+Coercion IR: gpreg >-> preg.
+Coercion FR: gpreg >-> preg.
+
+Lemma preg_eq: forall (x y: preg), {x=y} + {x<>y}.
+Proof. decide equality. apply ireg_eq. apply freg_eq. Defined.
+
+Module PregEq.
+  Definition t  := preg.
+  Definition eq := preg_eq.
+End PregEq.
+
+Module Pregmap := EMap(PregEq).
+
+(** Conventional names for stack pointer ([SP]) and return address ([RA]). *)
+
+Notation "'SP'" := GPR12 (only parsing) : asm.
+Notation "'FP'" := GPR10 (only parsing) : asm.
+Notation "'RTMP'" := GPR31 (only parsing) : asm.
+
+Inductive btest: Type :=
+  | BTdnez                              (**r Double Not Equal to Zero *)
+  | BTdeqz                              (**r Double Equal to Zero *)
+  | BTdltz                              (**r Double Less Than Zero *)
+  | BTdgez                              (**r Double Greater Than or Equal to Zero *)
+  | BTdlez                              (**r Double Less Than or Equal to Zero *)
+  | BTdgtz                              (**r Double Greater Than Zero *)
+(*| BTodd                               (**r Odd (LSB Set) *)
+  | BTeven                              (**r Even (LSB Clear) *)
+*)| BTwnez                              (**r Word Not Equal to Zero *)
+  | BTweqz                              (**r Word Equal to Zero *)
+  | BTwltz                              (**r Word Less Than Zero *)
+  | BTwgez                              (**r Word Greater Than or Equal to Zero *)
+  | BTwlez                              (**r Word Less Than or Equal to Zero *)
+  | BTwgtz                              (**r Word Greater Than Zero *)
+  .
+
+Inductive itest: Type :=
+  | ITne                                (**r Not Equal *)
+  | ITeq                                (**r Equal *)
+  | ITlt                                (**r Less Than *)
+  | ITge                                (**r Greater Than or Equal *)
+  | ITle                                (**r Less Than or Equal *)
+  | ITgt                                (**r Greater Than *)
+  | ITneu                               (**r Unsigned Not Equal *)
+  | ITequ                               (**r Unsigned Equal *)
+  | ITltu                               (**r Less Than Unsigned *)
+  | ITgeu                               (**r Greater Than or Equal Unsigned *)
+  | ITleu                               (**r Less Than or Equal Unsigned *)
+  | ITgtu                               (**r Greater Than Unsigned *)
+  (* Not used yet *)
+  | ITall                               (**r All Bits Set in Mask *)
+  | ITnall                              (**r Not All Bits Set in Mask *)
+  | ITany                               (**r Any Bits Set in Mask *)
+  | ITnone                              (**r Not Any Bits Set in Mask *)
+  .
+
+(** Offsets for load and store instructions.  An offset is either an
+  immediate integer or the low part of a symbol. *)
+
+Inductive offset : Type :=
+  | Ofsimm (ofs: ptrofs)
+  | Ofslow (id: ident) (ofs: ptrofs).
+
+(** We model a subset of the K1c instruction set. In particular, we do not
+  support floats yet.
+
+  Although it is possible to use the 32-bits mode, for now we don't support it.
+
+  We follow a design close to the one used for the Risc-V port: one set of
+  pseudo-instructions for 32-bit integer arithmetic, with suffix W, another
+  set for 64-bit integer arithmetic, with suffix L.
+
+  When mapping to actual instructions, the OCaml code in TargetPrinter.ml
+  throws an error if we are not in 64-bits mode.
+*)
+
+(** * Instructions *)
+
+Definition label := positive.
+
+(* FIXME - rewrite the comment *)
+(** A note on immediates: there are various constraints on immediate
+  operands to K1c instructions.  We do not attempt to capture these
+  restrictions in the abstract syntax nor in the semantics.  The
+  assembler will emit an error if immediate operands exceed the
+  representable range.  Of course, our K1c generator (file
+  [Asmgen]) is careful to respect this range. *)
+
+(** Instructions to be expanded in control-flow 
+*)
+Inductive ex_instruction : Type :=
+  (* Pseudo-instructions *)
+(*| Ploadsymbol_high (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the high part of the address of a symbol *)
+  | Pbtbl   (r: ireg)  (tbl: list label)            (**r N-way branch through a jump table *) *)
+
+  | Pbuiltin: external_function -> list (builtin_arg preg)
+              -> builtin_res preg -> ex_instruction   (**r built-in function (pseudo) *)
+.
+
+(** FIXME: comment not up to date !
+
+
+ The pseudo-instructions are the following:
+
+- [Ploadsymbol]: load the address of a symbol in an integer register.
+  Expands to the [la] assembler pseudo-instruction, which does the right
+  thing even if we are in PIC mode.
+
+- [Pallocframe sz pos]: in the formal semantics, this
+  pseudo-instruction allocates a memory block with bounds [0] and
+  [sz], stores the value of the stack pointer at offset [pos] in this
+  block, and sets the stack pointer to the address of the bottom of
+  this block.
+  In the printed ASM assembly code, this allocation is:
+<<
+        mv      x30, sp
+        sub     sp,  sp, #sz
+        sw      x30, #pos(sp)
+>>
+  This cannot be expressed in our memory model, which does not reflect
+  the fact that stack frames are adjacent and allocated/freed
+  following a stack discipline.
+
+- [Pfreeframe sz pos]: in the formal semantics, this pseudo-instruction
+  reads the word at [pos] of the block pointed by the stack pointer,
+  frees this block, and sets the stack pointer to the value read.
+  In the printed ASM assembly code, this freeing is just an increment of [sp]:
+<<
+        add     sp,  sp, #sz
+>>
+  Again, our memory model cannot comprehend that this operation
+  frees (logically) the current stack frame.
+
+- [Pbtbl reg table]: this is a N-way branch, implemented via a jump table
+  as follows:
+<<
+        la      x31, table
+        add     x31, x31, reg
+        jr      x31
+table:  .long   table[0], table[1], ...
+>>
+  Note that [reg] contains 4 times the index of the desired table entry.
+*)
+
+(** Control Flow instructions *)
+Inductive cf_instruction : Type :=
+  | Pret                                            (**r return *)
+  | Pcall   (l: label)                              (**r function call *)
+
+  (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *)
+  | Pgoto   (l: label)                              (**r goto *)
+  | Pj_l    (l: label)                              (**r jump to label *)
+
+  (* Conditional branches *)
+  | Pcb     (bt: btest) (r: ireg) (l: label)        (**r branch based on btest *)
+  | Pcbu    (bt: btest) (r: ireg) (l: label)        (**r branch based on btest with unsigned semantics *)
+.
+
+(** Loads **)
+Inductive load_name_rro : Type :=
+  | Plb                                             (**r load byte *)
+  | Plbu                                            (**r load byte unsigned *)
+  | Plh                                             (**r load half word *)
+  | Plhu                                            (**r load half word unsigned *)
+  | Plw                                             (**r load int32 *)
+  | Plw_a                                           (**r load any32 *)
+  | Pld                                             (**r load int64 *)
+  | Pld_a                                           (**r load any64 *)
+  | Pfls                                            (**r load float *)
+  | Pfld                                            (**r load 64-bit float *)
+.
+
+Inductive ld_instruction : Type :=
+  | PLoadRRO   (i: load_name_rro) (rd: ireg) (ra: ireg) (ofs: offset)
+.
+
+Coercion PLoadRRO:       load_name_rro        >-> Funclass.
+
+(** Stores **)
+Inductive store_name_rro : Type :=
+  | Psb                                             (**r store byte *)
+  | Psh                                             (**r store half byte *)
+  | Psw                                             (**r store int32 *)
+  | Psw_a                                           (**r store any32 *)
+  | Psd                                             (**r store int64 *)
+  | Psd_a                                           (**r store any64 *)
+  | Pfss                                            (**r store float *)
+  | Pfsd                                            (**r store 64-bit float *)
+.
+
+Inductive st_instruction : Type :=
+  | PStoreRRO  (i: store_name_rro) (rs: ireg) (ra: ireg) (ofs: offset)
+.
+
+Coercion PStoreRRO:       store_name_rro        >-> Funclass.
+
+(** Arithmetic instructions **)
+Inductive arith_name_r : Type :=
+  | Pcvtw2l                                         (**r Convert Word to Long *)
+  | Ploadsymbol (id: ident) (ofs: ptrofs)           (**r load the address of a symbol *)
+.
+
+Inductive arith_name_rr : Type :=
+  | Pmv                                             (**r register move *)
+  | Pnegw                                           (**r negate word *)
+  | Pnegl                                           (**r negate long *)
+  | Pfnegd                                          (**r float negate double *)
+  | Pcvtl2w                                         (**r Convert Long to Word *)
+  | Pmvw2l                                          (**r Move Convert Word to Long *)
+.
+
+Inductive arith_name_ri32 : Type :=
+  | Pmake                                           (**r load immediate *)
+.
+
+Inductive arith_name_ri64 : Type :=
+  | Pmakel                                          (**r load immediate long *)
+.
+
+Inductive arith_name_rrr : Type :=
+  | Pcompw  (it: itest)                             (**r comparison word *)
+  | Pcompl  (it: itest)                             (**r comparison long *)
+
+  | Paddw                                           (**r add word *)
+  | Psubw                                           (**r sub word *)
+  | Pmulw                                           (**r mul word *)
+  | Pandw                                           (**r and word *)
+  | Porw                                            (**r or word *)
+  | Pxorw                                           (**r xor word *)
+  | Psraw                                           (**r shift right arithmetic word *)
+  | Psrlw                                           (**r shift right logical word *)
+  | Psllw                                           (**r shift left logical word *)
+
+  | Paddl                                           (**r add long *)
+  | Psubl                                           (**r sub long *)
+  | Pandl                                           (**r and long *)
+  | Porl                                            (**r or long *)
+  | Pxorl                                           (**r xor long *)
+  | Pmull                                           (**r mul long (low part) *)
+  | Pslll                                           (**r shift left logical long *)
+  | Psrll                                           (**r shift right logical long *)
+  | Psral                                           (**r shift right arithmetic long *)
+.
+
+Inductive arith_name_rri32 : Type :=
+  | Pcompiw (it: itest)                             (**r comparison imm word *)
+
+  | Paddiw                                          (**r add imm word *)
+  | Pandiw                                          (**r and imm word *)
+  | Poriw                                           (**r or imm word *)
+  | Pxoriw                                          (**r xor imm word *)
+  | Psraiw                                          (**r shift right arithmetic imm word *)
+  | Psrliw                                          (**r shift right logical imm word *)
+  | Pslliw                                          (**r shift left logical imm word *)
+
+  | Psllil                                          (**r shift left logical immediate long *)
+  | Psrlil                                          (**r shift right logical immediate long *)
+  | Psrail                                          (**r shift right arithmetic immediate long *)
+.
+
+Inductive arith_name_rri64 : Type :=
+  | Pcompil (it: itest)                             (**r comparison imm long *)
+  | Paddil                                          (**r add immediate long *) 
+  | Pandil                                          (**r and immediate long *) 
+  | Poril                                           (**r or immediate long *) 
+  | Pxoril                                          (**r xor immediate long *) 
+.
+
+Inductive ar_instruction : Type :=
+  | PArithR     (i: arith_name_r)     (rd: ireg)
+  | PArithRR    (i: arith_name_rr)    (rd rs: ireg)
+  | PArithRI32  (i: arith_name_ri32)  (rd: ireg) (imm: int)
+  | PArithRI64  (i: arith_name_ri64)  (rd: ireg) (imm: int64)
+  | PArithRRR   (i: arith_name_rrr)   (rd rs1 rs2: ireg)
+  | PArithRRI32 (i: arith_name_rri32) (rd rs: ireg) (imm: int)
+  | PArithRRI64 (i: arith_name_rri64) (rd rs: ireg) (imm: int64)
+.
+
+Coercion PArithR:       arith_name_r        >-> Funclass.
+Coercion PArithRR:      arith_name_rr       >-> Funclass.
+Coercion PArithRI32:    arith_name_ri32     >-> Funclass.
+Coercion PArithRI64:    arith_name_ri64     >-> Funclass.
+Coercion PArithRRR:     arith_name_rrr      >-> Funclass.
+Coercion PArithRRI32:   arith_name_rri32    >-> Funclass.
+Coercion PArithRRI64:   arith_name_rri64    >-> Funclass.
+
+Inductive basic : Type :=
+  | PArith          (i: ar_instruction)
+  | PLoad           (i: ld_instruction)
+  | PStore          (i: st_instruction)
+  | Pallocframe (sz: Z) (pos: ptrofs)               (**r allocate new stack frame *)
+  | Pfreeframe  (sz: Z) (pos: ptrofs)               (**r deallocate stack frame and restore previous frame *)
+  | Pget    (rd: ireg) (rs: preg)                   (**r get system register *)
+  | Pset    (rd: preg) (rs: ireg)                   (**r set system register *)
+  | Pnop                                            (**r virtual instruction that does nothing *)
+.
+
+Coercion PLoad:         ld_instruction >-> basic.
+Coercion PStore:        st_instruction >-> basic.
+Coercion PArith:        ar_instruction >-> basic.
+
+
+Inductive control : Type :=
+  | PExpand         (i: ex_instruction)
+  | PCtlFlow        (i: cf_instruction)
+.
+
+Coercion PExpand:   ex_instruction >-> control.
+Coercion PCtlFlow:  cf_instruction >-> control.
+
+
+(** * Definition of a bblock *)
+
+Definition non_empty_bblock (body: list basic) (exit: option control): Prop
+ := body <> nil \/ exit <> None.
+
+Definition non_empty_body (body: list basic): bool :=
+  match body with
+  | nil => false
+  | _ => true
+  end.
+
+Definition non_empty_exit (exit: option control): bool :=
+  match exit with
+  | None => false
+  | _ => true
+  end.
+
+Definition non_empty_bblockb (body: list basic) (exit: option control): bool := non_empty_body body || non_empty_exit exit.
+
+Lemma non_empty_bblock_refl:
+  forall body exit,
+  non_empty_bblock body exit ->
+  Is_true (non_empty_bblockb body exit).
+Proof.
+  intros. destruct body; destruct exit.
+  all: simpl; auto.
+  inv H; contradiction.
+Qed.
+
+(* Definition builtin_alone (body: list basic) (exit: option control) := forall ef args res,
+  exit = Some (PExpand (Pbuiltin ef args res)) -> body = nil.
+ *)
+
+(* Definition wf_bblock (header: list label) (body: list basic) (exit: option control) :=
+  non_empty_bblock body exit (* /\ builtin_alone body exit *). *)
+
+(** A bblock is well-formed if he contains at least one instruction,
+    and if there is a builtin then it must be alone in this bblock. *)
+
+Record bblock := mk_bblock {
+  header: list label;
+  body: list basic;
+  exit: option control;
+  correct: Is_true (non_empty_bblockb body exit)
+}.
+
+Ltac bblock_auto_correct := (apply non_empty_bblock_refl; try discriminate; try (left; discriminate); try (right; discriminate)).
+(* Local Obligation Tactic := bblock_auto_correct. *)
+
+Lemma Istrue_proof_irrelevant (b: bool): forall (p1 p2:Is_true b), p1=p2.
+Proof.
+  destruct b; simpl; auto.
+  - destruct p1, p2; auto.
+  - destruct p1.
+Qed.
+
+Lemma bblock_equality bb1 bb2: header bb1=header bb2 -> body bb1 = body bb2 -> exit bb1 = exit bb2 -> bb1 = bb2.
+Proof.
+  destruct bb1 as [h1 b1 e1 c1], bb2 as [h2 b2 e2 c2]; simpl.
+  intros; subst.
+  rewrite (Istrue_proof_irrelevant _ c1 c2).
+  auto.
+Qed.
+
+
+(* FIXME: redundant with definition in Machblock *)
+Definition length_opt {A} (o: option A) : nat :=
+  match o with
+  | Some o => 1
+  | None => 0
+  end.
+
+(* WARNING: the notion of size is not the same than in Machblock !
+   We ignore labels here...
+   The result is in Z to be compatible with operations on PC
+*)
+Definition size (b:bblock): Z := Z.of_nat (length (body b) + length_opt (exit b)).
+(*   match (body b, exit b) with
+  | (nil, None) => 1
+  | _ => 
+  end.
+ *)
+
+Lemma length_nonil {A: Type} : forall l:(list A), l <> nil -> (length l > 0)%nat.
+Proof.
+  intros. destruct l; try (contradict H; auto; fail).
+  simpl. omega.
+Qed.
+
+Lemma to_nat_pos : forall z:Z, (Z.to_nat z > 0)%nat -> z > 0.
+Proof.
+  intros. destruct z; auto.
+  - contradict H. simpl. apply gt_irrefl.
+  - apply Zgt_pos_0.
+  - contradict H. simpl. apply gt_irrefl.
+Qed.
+
+Lemma size_positive (b:bblock): size b > 0.
+Proof.
+  unfold size. destruct b as [hd bdy ex cor]. simpl.
+  destruct ex; destruct bdy; try (apply to_nat_pos; rewrite Nat2Z.id; simpl; omega).
+  inversion cor; contradict H; simpl; auto.
+(*     rewrite eq. (* inversion COR. *) (* inversion H. *)
+  - assert ((length b > 0)%nat). apply length_nonil. auto.
+    omega.
+  - destruct e; simpl; try omega. contradict H; simpl; auto.
+ *)Qed.
+
+Definition bblocks := list bblock.
+
+Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks }.
+Definition fundef := AST.fundef function.
+Definition program := AST.program fundef unit.
+
+Inductive instruction : Type :=
+  | PBasic    (i: basic)
+  | PControl  (i: control)
+.
+
+Coercion PBasic:    basic >-> instruction.
+Coercion PControl:  control >-> instruction.
+
+Definition code := list instruction.
+Definition bcode := list basic.
+
+Fixpoint basics_to_code (l: list basic) :=
+  match l with
+  | nil => nil
+  | bi::l => (PBasic bi)::(basics_to_code l)
+  end.
+
+Fixpoint code_to_basics (c: code) :=
+  match c with
+  | (PBasic i)::c =>
+    match code_to_basics c with
+    | None => None
+    | Some l => Some (i::l)
+    end
+  | _::c => None
+  | nil => Some nil
+  end.
+
+Lemma code_to_basics_id: forall c, code_to_basics (basics_to_code c) = Some c.
+Proof.
+  intros. induction c as [|i c]; simpl; auto.
+  rewrite IHc. auto.
+Qed.
+
+Lemma code_to_basics_dist:
+  forall c c' l l',
+  code_to_basics c = Some l ->
+  code_to_basics c' = Some l' ->
+  code_to_basics (c ++ c') = Some (l ++ l').
+Proof.
+  induction c as [|i c]; simpl; auto.
+  - intros. inv H. simpl. auto.
+  - intros. destruct i; try discriminate. destruct (code_to_basics c) eqn:CTB; try discriminate.
+    inv H. erewrite IHc; eauto. auto.
+Qed.
+
+(** 
+  Asmblockgen will have to translate a Mach control into a list of instructions of the form
+   i1 :: i2 :: i3 :: ctl :: nil ; where i1..i3 are basic instructions, ctl is a control instruction
+  These functions provide way to extract the basic / control instructions
+*)
+
+Fixpoint extract_basic (c: code) :=
+  match c with
+  | nil => nil
+  | PBasic i :: c => i :: (extract_basic c)
+  | PControl i :: c => nil
+  end.
+
+Fixpoint extract_ctl (c: code) :=
+  match c with
+  | nil => None
+  | PBasic i :: c => extract_ctl c
+  | PControl i :: nil => Some i
+  | PControl i :: _ => None (* if the first found control instruction isn't the last *)
+  end.
+
+(** * Utility for Asmblockgen *)
+
+Program Definition bblock_single_inst (i: instruction) :=
+  match i with
+  | PBasic b => {| header:=nil; body:=(b::nil); exit:=None |}
+  | PControl ctl => {| header:=nil; body:=nil; exit:=(Some ctl) |}
+  end.
+
+Program Definition bblock_basic_ctl (c: list basic) (i: option control) :=
+  match i with
+  | Some i => {| header:=nil; body:=c; exit:=Some i |}
+  | None =>
+    match c with
+    | _::_ => {| header:=nil; body:=c; exit:=None |}
+    | nil => {| header:=nil; body:=Pnop::nil; exit:=None |}
+    end
+  end.
+Next Obligation.
+  bblock_auto_correct.
+Qed. Next Obligation.
+  bblock_auto_correct.
+Qed.
+
+
+(** * Operational semantics *)
+
+(** The semantics operates over a single mapping from registers
+  (type [preg]) to values.  We maintain
+  the convention that integer registers are mapped to values of
+  type [Tint] or [Tlong] (in 64 bit mode),
+  and float registers to values of type [Tsingle] or [Tfloat]. *)
+
+Definition regset := Pregmap.t val.
+
+Definition genv := Genv.t fundef unit.
+
+Notation "a # b" := (a b) (at level 1, only parsing) : asm.
+Notation "a # b <- c" := (Pregmap.set b c a) (at level 1, b at next level) : asm.
+
+Open Scope asm.
+
+(** Undefining some registers *)
+
+Fixpoint undef_regs (l: list preg) (rs: regset) : regset :=
+  match l with
+  | nil => rs
+  | r :: l' => undef_regs l' (rs#r <- Vundef)
+  end.
+
+
+(** Assigning a register pair *)
+Definition set_pair (p: rpair preg) (v: val) (rs: regset) : regset :=
+  match p with
+  | One r => rs#r <- v
+  | Twolong rhi rlo => rs#rhi <- (Val.hiword v) #rlo <- (Val.loword v)
+  end.
+
+(* TODO: Is it still useful ?? *)
+
+
+(** Assigning multiple registers *)
+
+(* Fixpoint set_regs (rl: list preg) (vl: list val) (rs: regset) : regset :=
+  match rl, vl with
+  | r1 :: rl', v1 :: vl' => set_regs rl' vl' (rs#r1 <- v1)
+  | _, _ => rs
+  end.
+ *)
+(** Assigning the result of a builtin *)
+
+Fixpoint set_res (res: builtin_res preg) (v: val) (rs: regset) : regset :=
+  match res with
+  | BR r => rs#r <- v
+  | BR_none => rs
+  | BR_splitlong hi lo => set_res lo (Val.loword v) (set_res hi (Val.hiword v) rs)
+  end.
+
+Section RELSEM.
+
+
+(** The semantics is purely small-step and defined as a function
+  from the current state (a register set + a memory state)
+  to either [Next rs' m'] where [rs'] and [m'] are the updated register
+  set and memory state after execution of the instruction at [rs#PC],
+  or [Stuck] if the processor is stuck. *)
+
+Inductive outcome {rgset}: Type :=
+  | Next (rs:rgset) (m:mem)
+  | Stuck.
+Arguments outcome: clear implicits.
+
+
+(** ** Arithmetic Expressions (including comparisons) *)
+
+Inductive signedness: Type := Signed | Unsigned.
+
+Inductive intsize: Type := Int | Long.
+
+Definition itest_for_cmp (c: comparison) (s: signedness) :=
+  match c, s with
+  | Cne, Signed => ITne
+  | Ceq, Signed => ITeq
+  | Clt, Signed => ITlt
+  | Cge, Signed => ITge
+  | Cle, Signed => ITle
+  | Cgt, Signed => ITgt
+  | Cne, Unsigned => ITneu
+  | Ceq, Unsigned => ITequ
+  | Clt, Unsigned => ITltu
+  | Cge, Unsigned => ITgeu
+  | Cle, Unsigned => ITleu
+  | Cgt, Unsigned => ITgtu
+  end.
+
+(* CoMPare Signed Words to Zero *)
+Definition btest_for_cmpswz (c: comparison) :=
+  match c with
+  | Cne => BTwnez
+  | Ceq => BTweqz
+  | Clt => BTwltz
+  | Cge => BTwgez
+  | Cle => BTwlez
+  | Cgt => BTwgtz
+  end.
+
+(* CoMPare Signed Doubles to Zero *)
+Definition btest_for_cmpsdz (c: comparison) :=
+  match c with
+  | Cne => BTdnez
+  | Ceq => BTdeqz
+  | Clt => BTdltz
+  | Cge => BTdgez
+  | Cle => BTdlez
+  | Cgt => BTdgtz
+  end.
+
+Definition cmp_for_btest (bt: btest) :=
+  match bt with
+  | BTwnez => (Some Cne, Int)
+  | BTweqz => (Some Ceq, Int)
+  | BTwltz => (Some Clt, Int)
+  | BTwgez => (Some Cge, Int)
+  | BTwlez => (Some Cle, Int)
+  | BTwgtz => (Some Cgt, Int)
+
+  | BTdnez => (Some Cne, Long)
+  | BTdeqz => (Some Ceq, Long)
+  | BTdltz => (Some Clt, Long)
+  | BTdgez => (Some Cge, Long)
+  | BTdlez => (Some Cle, Long)
+  | BTdgtz => (Some Cgt, Long)
+  end.
+
+Definition cmpu_for_btest (bt: btest) :=
+  match bt with
+  | BTwnez => (Some Cne, Int)
+  | BTweqz => (Some Ceq, Int)
+  | BTdnez => (Some Cne, Long)
+  | BTdeqz => (Some Ceq, Long)
+  | _ => (None, Int)
+  end.
+
+(** Comparing integers *)
+Definition compare_int (t: itest) (v1 v2: val) (m: mem): val :=
+  match t with
+  | ITne  => Val.cmp Cne v1 v2
+  | ITeq  => Val.cmp Ceq v1 v2
+  | ITlt  => Val.cmp Clt v1 v2
+  | ITge  => Val.cmp Cge v1 v2
+  | ITle  => Val.cmp Cle v1 v2
+  | ITgt  => Val.cmp Cgt v1 v2
+  | ITneu => Val.cmpu (Mem.valid_pointer m) Cne v1 v2
+  | ITequ => Val.cmpu (Mem.valid_pointer m) Ceq v1 v2
+  | ITltu => Val.cmpu (Mem.valid_pointer m) Clt v1 v2
+  | ITgeu => Val.cmpu (Mem.valid_pointer m) Cge v1 v2
+  | ITleu => Val.cmpu (Mem.valid_pointer m) Cle v1 v2
+  | ITgtu => Val.cmpu (Mem.valid_pointer m) Cgt v1 v2
+  | ITall
+  | ITnall
+  | ITany
+  | ITnone => Vundef
+  end.
+
+Definition compare_long (t: itest) (v1 v2: val) (m: mem): val :=
+  let res := match t with
+  | ITne  => Val.cmpl Cne v1 v2
+  | ITeq  => Val.cmpl Ceq v1 v2
+  | ITlt  => Val.cmpl Clt v1 v2
+  | ITge  => Val.cmpl Cge v1 v2
+  | ITle  => Val.cmpl Cle v1 v2
+  | ITgt  => Val.cmpl Cgt v1 v2
+  | ITneu => Val.cmplu (Mem.valid_pointer m) Cne v1 v2
+  | ITequ => Val.cmplu (Mem.valid_pointer m) Ceq v1 v2
+  | ITltu => Val.cmplu (Mem.valid_pointer m) Clt v1 v2
+  | ITgeu => Val.cmplu (Mem.valid_pointer m) Cge v1 v2
+  | ITleu => Val.cmplu (Mem.valid_pointer m) Cle v1 v2
+  | ITgtu => Val.cmplu (Mem.valid_pointer m) Cgt v1 v2
+  | ITall
+  | ITnall
+  | ITany
+  | ITnone => Some Vundef
+  end in 
+  match res with
+  | Some v => v
+  | None => Vundef
+  end
+  .
+(** Execution of arith instructions 
+
+TODO: subsplitting by instruction type ? Could be useful for expressing auxiliary lemma...
+
+FIXME: replace parameter "m" by a function corresponding to the resul of "(Mem.valid_pointer m)"
+
+*)
+
+Variable ge: genv.
+
+
+Definition exec_arith_instr (ai: ar_instruction) (rs: regset) (m: mem) : regset :=
+  match ai with
+  | PArithR n d =>
+      match n with
+      | Pcvtw2l => rs#d <- (Val.longofint rs#d)
+      | Ploadsymbol s ofs => rs#d <- (Genv.symbol_address ge s ofs)
+      end
+
+  | PArithRR n d s =>
+      match n with
+      | Pmv => rs#d <- (rs#s)
+      | Pnegw => rs#d <- (Val.neg rs#s)
+      | Pnegl => rs#d <- (Val.negl rs#s)
+      | Pfnegd => rs#d <- (Val.negf rs#s)
+      | Pcvtl2w => rs#d <- (Val.loword rs#s)
+      | Pmvw2l => rs#d <- (Val.longofint rs#s)
+      end
+
+  | PArithRI32 n d i =>
+      match n with
+      | Pmake => rs#d <- (Vint i)
+      end
+
+  | PArithRI64 n d i =>
+      match n with
+      | Pmakel => rs#d <- (Vlong i)
+      end
+
+  | PArithRRR n d s1 s2 =>
+      match n with
+      | Pcompw c => rs#d <- (compare_int c rs#s1 rs#s2 m)
+      | Pcompl c => rs#d <- (compare_long c rs#s1 rs#s2 m)
+      | Paddw  => rs#d <- (Val.add  rs#s1 rs#s2)
+      | Psubw  => rs#d <- (Val.sub  rs#s1 rs#s2)
+      | Pmulw  => rs#d <- (Val.mul  rs#s1 rs#s2)
+      | Pandw  => rs#d <- (Val.and  rs#s1 rs#s2)
+      | Porw   => rs#d <- (Val.or   rs#s1 rs#s2)
+      | Pxorw  => rs#d <- (Val.xor  rs#s1 rs#s2)
+      | Psrlw  => rs#d <- (Val.shru rs#s1 rs#s2)
+      | Psraw  => rs#d <- (Val.shr  rs#s1 rs#s2)
+      | Psllw  => rs#d <- (Val.shl  rs#s1 rs#s2)
+
+      | Paddl => rs#d <- (Val.addl rs#s1 rs#s2)
+      | Psubl => rs#d <- (Val.subl rs#s1 rs#s2)
+      | Pandl => rs#d <- (Val.andl rs#s1 rs#s2)
+      | Porl  => rs#d <- (Val.orl  rs#s1 rs#s2)
+      | Pxorl  => rs#d <- (Val.xorl  rs#s1 rs#s2)
+      | Pmull => rs#d <- (Val.mull rs#s1 rs#s2)
+      | Pslll => rs#d <- (Val.shll rs#s1 rs#s2)
+      | Psrll => rs#d <- (Val.shrlu rs#s1 rs#s2)
+      | Psral => rs#d <- (Val.shrl rs#s1 rs#s2)
+      end
+
+  | PArithRRI32 n d s i =>
+      match n with
+      | Pcompiw c => rs#d <- (compare_int c rs#s (Vint i) m)
+      | Paddiw  => rs#d <- (Val.add   rs#s (Vint i))
+      | Pandiw  => rs#d <- (Val.and   rs#s (Vint i))
+      | Poriw   => rs#d <- (Val.or    rs#s (Vint i))
+      | Pxoriw  => rs#d <- (Val.xor   rs#s (Vint i))
+      | Psraiw  => rs#d <- (Val.shr   rs#s (Vint i))
+      | Psrliw  => rs#d <- (Val.shru  rs#s (Vint i))
+      | Pslliw  => rs#d <- (Val.shl   rs#s (Vint i))
+      | Psllil  => rs#d <- (Val.shll  rs#s (Vint i))
+      | Psrlil  => rs#d <- (Val.shrlu rs#s (Vint i))
+      | Psrail  => rs#d <- (Val.shrl  rs#s (Vint i))
+      end
+
+  | PArithRRI64 n d s i =>
+      match n with
+      | Pcompil c => rs#d <- (compare_long c rs#s (Vlong i) m)
+      | Paddil  => rs#d <- (Val.addl rs#s (Vlong i))
+      | Pandil  => rs#d <- (Val.andl rs#s (Vlong i))
+      | Poril   => rs#d <- (Val.orl  rs#s (Vlong i))
+      | Pxoril  => rs#d <- (Val.xorl  rs#s (Vlong i))
+      end
+  end.
+
+(** * load/store *)
+
+(** The two functions below axiomatize how the linker processes
+  symbolic references [symbol + offset)] and splits their
+  actual values into a 20-bit high part [%hi(symbol + offset)] and 
+  a 12-bit low part [%lo(symbol + offset)]. *)
+
+Parameter low_half: genv -> ident -> ptrofs -> ptrofs.
+Parameter high_half: genv -> ident -> ptrofs -> val.
+
+(** The fundamental property of these operations is that, when applied
+  to the address of a symbol, their results can be recombined by
+  addition, rebuilding the original address. *)
+
+Axiom low_high_half:
+  forall id ofs,
+  Val.offset_ptr (high_half ge id ofs) (low_half ge id ofs) = Genv.symbol_address ge id ofs.
+
+(** Auxiliaries for memory accesses *)
+
+Definition eval_offset (ofs: offset) : ptrofs :=
+  match ofs with
+  | Ofsimm n => n
+  | Ofslow id delta => low_half ge id delta
+  end.
+
+Definition exec_load (chunk: memory_chunk) (rs: regset) (m: mem)
+                     (d: preg) (a: ireg) (ofs: offset) :=
+  match Mem.loadv chunk m (Val.offset_ptr (rs a) (eval_offset ofs)) with
+  | None => Stuck
+  | Some v => Next (rs#d <- v) m
+  end.
+
+Definition exec_store (chunk: memory_chunk) (rs: regset) (m: mem)
+                      (s: preg) (a: ireg) (ofs: offset) :=
+  match Mem.storev chunk m (Val.offset_ptr (rs a) (eval_offset ofs)) (rs s) with
+  | None => Stuck
+  | Some m' => Next rs m'
+  end.
+
+(** * basic instructions *)
+
+Definition exec_basic_instr (bi: basic) (rs: regset) (m: mem) : outcome regset :=
+ match bi with
+ | PArith ai => Next (exec_arith_instr ai rs m) m
+
+ | PLoadRRO n d a ofs =>
+      match n with
+        | Plb => exec_load Mint8signed rs m d a ofs
+        | Plbu => exec_load Mint8unsigned rs m d a ofs
+        | Plh => exec_load Mint16signed rs m d a ofs
+        | Plhu => exec_load Mint16unsigned rs m d a ofs
+        | Plw => exec_load Mint32 rs m d a ofs
+        | Plw_a => exec_load Many32 rs m d a ofs
+        | Pld => exec_load Mint64 rs m d a ofs
+        | Pld_a => exec_load Many64 rs m d a ofs
+        | Pfls => exec_load Mfloat32 rs m d a ofs
+        | Pfld => exec_load Mfloat64 rs m d a ofs
+      end
+
+  | PStoreRRO n s a ofs =>
+      match n with
+        | Psb => exec_store Mint8unsigned rs m s a ofs
+        | Psh => exec_store Mint16unsigned rs m s a ofs
+        | Psw => exec_store Mint32 rs m s a ofs
+        | Psw_a => exec_store Many32 rs m s a ofs
+        | Psd => exec_store Mint64 rs m s a ofs
+        | Psd_a => exec_store Many64 rs m s a ofs
+        | Pfss => exec_store Mfloat32 rs m s a ofs
+        | Pfsd => exec_store Mfloat64 rs m s a ofs
+      end
+
+  | Pallocframe sz pos =>
+      let (m1, stk) := Mem.alloc m 0 sz in
+      let sp := (Vptr stk Ptrofs.zero) in
+      match Mem.storev Mptr m1 (Val.offset_ptr sp pos) rs#SP with
+      | None => Stuck
+      | Some m2 => Next (rs #FP <- (rs SP) #SP <- sp #GPR31 <- Vundef) m2
+      end
+
+  | Pfreeframe sz pos =>
+      match Mem.loadv Mptr m (Val.offset_ptr rs#SP pos) with
+      | None => Stuck
+      | Some v =>
+          match rs SP with
+          | Vptr stk ofs =>
+              match Mem.free m stk 0 sz with
+              | None => Stuck
+              | Some m' => Next (rs#SP <- v #GPR31 <- Vundef) m'
+              end
+          | _ => Stuck
+          end
+      end
+  | Pget rd ra =>
+    match ra with
+    | RA => Next (rs#rd <- (rs#ra)) m
+    | _  => Stuck
+    end
+  | Pset ra rd =>
+    match ra with
+    | RA => Next (rs#ra <- (rs#rd)) m
+    | _  => Stuck
+    end
+  | Pnop => Next rs m
+end.
+
+Fixpoint exec_body (body: list basic) (rs: regset) (m: mem): outcome regset :=
+  match body with
+  | nil => Next rs m
+  | bi::body' => 
+     match exec_basic_instr bi rs m with
+     | Next rs' m' => exec_body body' rs' m'
+     | Stuck => Stuck
+     end
+  end.
+
+(** Manipulations over the [PC] register: continuing with the next
+  instruction ([nextblock]) or branching to a label ([goto_label]). *)
+
+Definition nextblock (b:bblock) (rs: regset) :=
+  rs#PC <- (Val.offset_ptr rs#PC (Ptrofs.repr (size b))).
+
+(** Looking up bblocks in a code sequence by position. *)
+Fixpoint find_bblock (pos: Z) (lb: bblocks) {struct lb} : option bblock :=
+  match lb with
+  | nil => None
+  | b :: il => 
+    if zlt pos 0 then None  (* NOTE: It is impossible to branch inside a block *)
+    else if zeq pos 0 then Some b
+    else find_bblock (pos - (size b)) il
+  end.
+
+
+(** Position corresponding to a label *)
+
+(** TODO: redundant w.r.t Machblock *)
+Lemma in_dec (lbl: label) (l: list label):  { List.In lbl l } + { ~(List.In lbl l) }.
+Proof.
+  apply List.in_dec.
+  apply Pos.eq_dec.
+Qed.
+
+
+(** Note: copy-paste from Machblock *)
+Definition is_label (lbl: label) (bb: bblock) : bool :=
+  if in_dec lbl (header bb) then true else false.
+
+Lemma is_label_correct_true lbl bb:
+  List.In lbl (header bb) <-> is_label lbl bb = true. 
+Proof.
+  unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition.
+Qed.
+
+Lemma is_label_correct_false lbl bb:
+  ~(List.In lbl (header bb)) <-> is_label lbl bb = false. 
+Proof.
+  unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition.
+Qed.
+
+(** convert a label into a position in the code *)
+Fixpoint label_pos (lbl: label) (pos: Z) (lb: bblocks) {struct lb} : option Z :=
+  match lb with
+  | nil => None
+  | b :: lb' => if is_label lbl b then Some pos else label_pos lbl (pos + (size b)) lb'
+  end.
+
+Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) : outcome regset :=
+  match label_pos lbl 0 (fn_blocks f) with
+  | None => Stuck
+  | Some pos =>
+      match rs#PC with
+      | Vptr b ofs => Next (rs#PC <- (Vptr b (Ptrofs.repr pos))) m
+      | _          => Stuck
+      end
+  end.
+
+(** Evaluating a branch 
+
+Warning: in m PC is assumed to be already pointing on the next instruction !
+
+*)
+Definition eval_branch (f: function) (l: label) (rs: regset) (m: mem) (res: option bool) : outcome regset :=
+  match res with
+    | Some true  => goto_label f l rs m
+    | Some false => Next rs m
+    | None => Stuck
+  end.
+
+
+(** Execution of a single control-flow instruction [i] in initial state [rs] and
+    [m].  Return updated state.
+
+    As above: PC is assumed to be incremented on the next block before the control-flow instruction
+
+    For instructions that correspond tobuiltin
+    actual RISC-V instructions, the cases are straightforward
+    transliterations of the informal descriptions given in the RISC-V
+    user-mode specification.  For pseudo-instructions, refer to the
+    informal descriptions given above.
+
+    Note that we set to [Vundef] the registers used as temporaries by
+    the expansions of the pseudo-instructions, so that the RISC-V code
+    we generate cannot use those registers to hold values that must
+    survive the execution of the pseudo-instruction. *)
+
+Definition exec_control (f: function) (oc: option control) (rs: regset) (m: mem) : outcome regset :=
+  match oc with
+  | Some ic =>
+(** Get/Set system registers *)
+  match ic with
+
+
+(** Branch Control Unit instructions *)
+  | Pret =>
+      Next (rs#PC <- (rs#RA)) m
+  | Pcall s =>
+      Next (rs#RA <- (rs#PC) #PC <- (Genv.symbol_address ge s Ptrofs.zero)) m
+  | Pgoto s =>
+      Next (rs#PC <- (Genv.symbol_address ge s Ptrofs.zero)) m
+  | Pj_l l =>
+      goto_label f l rs m
+  | Pcb bt r l =>
+      match cmp_for_btest bt with
+      | (Some c, Int)  => eval_branch f l rs m (Val.cmp_bool c rs#r (Vint (Int.repr 0)))
+      | (Some c, Long) => eval_branch f l rs m (Val.cmpl_bool c rs#r (Vlong (Int64.repr 0)))
+      | (None, _) => Stuck
+      end
+  | Pcbu bt r l => 
+      match cmpu_for_btest bt with
+      | (Some c, Int) => eval_branch f l rs m (Val.cmpu_bool (Mem.valid_pointer m) c rs#r (Vint (Int.repr 0)))
+      | (Some c, Long) => eval_branch f l rs m (Val.cmplu_bool (Mem.valid_pointer m) c rs#r (Vlong (Int64.repr 0)))
+      | (None, _) => Stuck
+      end
+
+
+(** Pseudo-instructions *)
+  | Pbuiltin ef args res =>
+      Stuck (**r treated specially below *)
+  end
+  | None => Next rs m
+end.
+
+Definition exec_bblock (f: function) (b: bblock) (rs0: regset) (m: mem) : outcome regset :=
+  match exec_body (body b) rs0 m with
+  | Next rs' m' =>
+    let rs1 := nextblock b rs' in exec_control f (exit b) rs1 m'
+  | Stuck => Stuck
+  end.
+
+(** Translation of the LTL/Linear/Mach view of machine registers to
+  the RISC-V view.  Note that no LTL register maps to [X31].  This
+  register is reserved as temporary, to be used by the generated RV32G
+  code.  *)
+
+  (* FIXME - R31 is not there *)
+Definition preg_of (r: mreg) : preg :=
+  match r with
+  | R0  => GPR0  | R1  => GPR1  | R2  => GPR2  | R3  => GPR3  | R4  => GPR4
+  | R5  => GPR5  | R6  => GPR6  | R7  => GPR7                 | R9  => GPR9
+  | R10 => GPR10 (*| R11 => GPR11 | R12 => GPR12 | R13 => GPR13 | R14  => GPR14 *)
+  | R15 => GPR15 | R16 => GPR16 | R17 => GPR17 | R18 => GPR18 | R19  => GPR19
+  | R20 => GPR20 | R21 => GPR21 | R22 => GPR22 | R23 => GPR23 | R24  => GPR24
+  | R25 => GPR25 | R26 => GPR26 | R27 => GPR27 | R28 => GPR28 | R29  => GPR29
+  | R30 => GPR30 |                R32 => GPR32 | R33 => GPR33 | R34  => GPR34
+  | R35 => GPR35 | R36 => GPR36 | R37 => GPR37 | R38 => GPR38 | R39  => GPR39
+  | R40 => GPR40 | R41 => GPR41 | R42 => GPR42 | R43 => GPR43 | R44  => GPR44
+  | R45 => GPR45 | R46 => GPR46 | R47 => GPR47 | R48 => GPR48 | R49  => GPR49
+  | R50 => GPR50 | R51 => GPR51 | R52 => GPR52 | R53 => GPR53 | R54  => GPR54
+  | R55 => GPR55 | R56 => GPR56 | R57 => GPR57 | R58 => GPR58 | R59  => GPR59
+  | R60 => GPR60 | R61 => GPR61 | R62 => GPR62 | R63 => GPR63
+  end.
+
+(** Extract the values of the arguments of an external call.
+    We exploit the calling conventions from module [Conventions], except that
+    we use RISC-V registers instead of locations. *)
+
+Inductive extcall_arg (rs: regset) (m: mem): loc -> val -> Prop :=
+  | extcall_arg_reg: forall r,
+      extcall_arg rs m (R r) (rs (preg_of r))
+  | extcall_arg_stack: forall ofs ty bofs v,
+      bofs = Stacklayout.fe_ofs_arg + 4 * ofs ->
+      Mem.loadv (chunk_of_type ty) m
+                (Val.offset_ptr rs#SP (Ptrofs.repr bofs)) = Some v ->
+      extcall_arg rs m (S Outgoing ofs ty) v.
+
+Inductive extcall_arg_pair (rs: regset) (m: mem): rpair loc -> val -> Prop :=
+  | extcall_arg_one: forall l v,
+      extcall_arg rs m l v ->
+      extcall_arg_pair rs m (One l) v
+  | extcall_arg_twolong: forall hi lo vhi vlo,
+      extcall_arg rs m hi vhi ->
+      extcall_arg rs m lo vlo ->
+      extcall_arg_pair rs m (Twolong hi lo) (Val.longofwords vhi vlo).
+
+Definition extcall_arguments
+    (rs: regset) (m: mem) (sg: signature) (args: list val) : Prop :=
+  list_forall2 (extcall_arg_pair rs m) (loc_arguments sg) args.
+
+Definition loc_external_result (sg: signature) : rpair preg :=
+  map_rpair preg_of (loc_result sg).
+
+(** Execution of the instruction at [rs PC]. *)
+
+Inductive state: Type :=
+  | State: regset -> mem -> state.
+
+
+(** TODO
+ * For now, we consider a builtin is alone in a basic block.
+ * Perhaps there is a way to avoid that ?
+ *)
+
+Inductive step: state -> trace -> state -> Prop :=
+  | exec_step_internal:
+      forall b ofs f bi rs m rs' m',
+      rs PC = Vptr b ofs ->
+      Genv.find_funct_ptr ge b = Some (Internal f) ->
+      find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bi ->
+      exec_bblock f bi rs m = Next rs' m' ->
+      step (State rs m) E0 (State rs' m')
+  | exec_step_builtin:
+      forall b ofs f ef args res rs m vargs t vres rs' m' bi,
+      rs PC = Vptr b ofs ->
+      Genv.find_funct_ptr ge b = Some (Internal f) ->
+      find_bblock (Ptrofs.unsigned ofs) f.(fn_blocks) = Some bi ->
+      exit bi = Some (PExpand (Pbuiltin ef args res)) ->
+      eval_builtin_args ge rs (rs SP) m args vargs ->
+      external_call ef ge vargs m t vres m' ->
+      rs' = nextblock bi
+              (set_res res vres
+                (undef_regs (map preg_of (destroyed_by_builtin ef))
+                   (rs#GPR31 <- Vundef))) ->
+      step (State rs m) t (State rs' m')
+  | exec_step_external:
+      forall b ef args res rs m t rs' m',
+      rs PC = Vptr b Ptrofs.zero ->
+      Genv.find_funct_ptr ge b = Some (External ef) ->
+      external_call ef ge args m t res m' ->
+      extcall_arguments rs m (ef_sig ef) args ->
+      rs' = (set_pair (loc_external_result (ef_sig ef) ) res rs)#PC <- (rs RA) ->
+      step (State rs m) t (State rs' m')
+  .
+
+
+
+End RELSEM.
+
+(** Execution of whole programs. *)
+
+Inductive initial_state (p: program): state -> Prop :=
+  | initial_state_intro: forall m0,
+      let ge := Genv.globalenv p in
+      let rs0 :=
+        (Pregmap.init Vundef)
+        # PC <- (Genv.symbol_address ge p.(prog_main) Ptrofs.zero)
+        # SP <- Vnullptr
+        # RA <- Vnullptr in
+      Genv.init_mem p = Some m0 ->
+      initial_state p (State rs0 m0).
+
+Inductive final_state: state -> int -> Prop :=
+  | final_state_intro: forall rs m r,
+      rs PC = Vnullptr ->
+      rs GPR0 = Vint r ->
+      final_state (State rs m) r.
+
+Definition semantics (p: program) :=
+  Semantics step (initial_state p) final_state (Genv.globalenv p).
+
+Remark extcall_arguments_determ:
+  forall rs m sg args1 args2,
+  extcall_arguments rs m sg args1 -> extcall_arguments rs m sg args2 -> args1 = args2.
+Proof.
+  intros until m.
+  assert (A: forall l v1 v2,
+             extcall_arg rs m l v1 -> extcall_arg rs m l v2 -> v1 = v2).
+  { intros. inv H; inv H0; congruence. }
+  assert (B: forall p v1 v2,
+             extcall_arg_pair rs m p v1 -> extcall_arg_pair rs m p v2 -> v1 = v2).
+  { intros. inv H; inv H0. 
+    eapply A; eauto.
+    f_equal; eapply A; eauto. }
+  assert (C: forall ll vl1, list_forall2 (extcall_arg_pair rs m) ll vl1 ->
+             forall vl2, list_forall2 (extcall_arg_pair rs m) ll vl2 -> vl1 = vl2).
+  {
+    induction 1; intros vl2 EA; inv EA.
+    auto.
+    f_equal; eauto. }
+  intros. eapply C; eauto.
+Qed.
+
+Lemma semantics_determinate: forall p, determinate (semantics p).
+Proof.
+Ltac Equalities :=
+  match goal with
+  | [ H1: ?a = ?b, H2: ?a = ?c |- _ ] =>
+      rewrite H1 in H2; inv H2; Equalities
+  | _ => idtac
+  end.
+  intros; constructor; simpl; intros.
+- (* determ *)
+  inv H; inv H0; Equalities.
+  + split. constructor. auto.
+  + unfold exec_bblock in H4. destruct (exec_body _ _ _ _); try discriminate.
+    rewrite H9 in H4. discriminate.
+  + unfold exec_bblock in H13. destruct (exec_body _ _ _ _); try discriminate.
+    rewrite H4 in H13. discriminate.
+  + assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0.
+    exploit external_call_determ. eexact H6. eexact H13. intros [A B].
+    split. auto. intros. destruct B; auto. subst. auto.
+  + assert (args0 = args) by (eapply extcall_arguments_determ; eauto). subst args0.
+    exploit external_call_determ. eexact H3. eexact H8. intros [A B].
+    split. auto. intros. destruct B; auto. subst. auto.
+- (* trace length *)
+  red; intros. inv H; simpl.
+  omega.
+  eapply external_call_trace_length; eauto.
+  eapply external_call_trace_length; eauto.
+- (* initial states *)
+  inv H; inv H0. f_equal. congruence.
+- (* final no step *)
+  assert (NOTNULL: forall b ofs, Vnullptr <> Vptr b ofs).
+  { intros; unfold Vnullptr; destruct Archi.ptr64; congruence. }
+  inv H. unfold Vzero in H0. red; intros; red; intros.
+  inv H; rewrite H0 in *; eelim NOTNULL; eauto.
+- (* final states *)
+  inv H; inv H0. congruence.
+Qed.
+
+Definition data_preg (r: preg) : bool :=

+  match r with

+  | RA  => false

+  | IR GPR31 => false

+  | IR GPR8 => false

+  | IR _   => true

+  | FR _   => true

+  | PC     => false

+  end.

+

+(** Determinacy of the [Asm] semantics. *)

+

+(* TODO.

+

+Remark extcall_arguments_determ:

+  forall rs m sg args1 args2,

+  extcall_arguments rs m sg args1 -> extcall_arguments rs m sg args2 -> args1 = args2.

+Proof.

+  intros until m.

+  assert (A: forall l v1 v2,

+             extcall_arg rs m l v1 -> extcall_arg rs m l v2 -> v1 = v2).

+  { intros. inv H; inv H0; congruence. }

+  assert (B: forall p v1 v2,

+             extcall_arg_pair rs m p v1 -> extcall_arg_pair rs m p v2 -> v1 = v2).

+  { intros. inv H; inv H0. 

+    eapply A; eauto.

+    f_equal; eapply A; eauto. }

+  assert (C: forall ll vl1, list_forall2 (extcall_arg_pair rs m) ll vl1 ->

+             forall vl2, list_forall2 (extcall_arg_pair rs m) ll vl2 -> vl1 = vl2).

+  {

+    induction 1; intros vl2 EA; inv EA.

+    auto.

+    f_equal; eauto. }

+  intros. eapply C; eauto.

+Qed.

+

+Lemma semantics_determinate: forall p, determinate (semantics p).

+Proof.

+Ltac Equalities :=

+  match goal with

+  | [ H1: ?a = ?b, H2: ?a = ?c |- _ ] =>

+      rewrite H1 in H2; inv H2; Equalities

+  | _ => idtac

+  end.

+  intros; constructor; simpl; intros.

+- (* determ *)

+  inv H; inv H0; Equalities.

+  split. constructor. auto.

+  discriminate.

+  discriminate.

+  assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0.

+  exploit external_call_determ. eexact H5. eexact H11. intros [A B].

+  split. auto. intros. destruct B; auto. subst. auto.

+  assert (args0 = args) by (eapply extcall_arguments_determ; eauto). subst args0.

+  exploit external_call_determ. eexact H3. eexact H8. intros [A B].

+  split. auto. intros. destruct B; auto. subst. auto.

+- (* trace length *)

+  red; intros. inv H; simpl.

+  omega.

+  eapply external_call_trace_length; eauto.

+  eapply external_call_trace_length; eauto.

+- (* initial states *)

+  inv H; inv H0. f_equal. congruence.

+- (* final no step *)

+  assert (NOTNULL: forall b ofs, Vnullptr <> Vptr b ofs).

+  { intros; unfold Vnullptr; destruct Archi.ptr64; congruence. }

+  inv H. unfold Vzero in H0. red; intros; red; intros.

+  inv H; rewrite H0 in *; eelim NOTNULL; eauto.

+- (* final states *)

+  inv H; inv H0. congruence.

+Qed.

+*)

diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v
new file mode 100644
index 00000000..e16c701f
--- /dev/null
+++ b/mppa_k1c/Asmblockgen.v
@@ -0,0 +1,943 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              The Compcert verified compiler                         *)
+(*                                                                     *)
+(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
+(*           Prashanth Mundkur, SRI International                      *)
+(*                                                                     *)
+(*  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.     *)
+(*                                                                     *)
+(*  The contributions by Prashanth Mundkur are reused and adapted      *)
+(*  under the terms of a Contributor License Agreement between         *)
+(*  SRI International and INRIA.                                       *)
+(*                                                                     *)
+(* *********************************************************************)
+
+(** Translation from Machblock to K1c assembly language (Asmblock) *)
+
+Require Archi.
+Require Import Coqlib Errors.
+Require Import AST Integers Floats Memdata.
+Require Import Op Locations Machblock Asmblock.
+
+Local Open Scope string_scope.
+Local Open Scope error_monad_scope.
+
+(** The code generation functions take advantage of several
+  characteristics of the [Mach] code generated by earlier passes of the
+  compiler, mostly that argument and result registers are of the correct
+  types.  These properties are true by construction, but it's easier to
+  recheck them during code generation and fail if they do not hold. *)
+
+(** 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 IR mr => OK mr | _ => Error(msg "Asmgen.freg_of") end.
+
+(*
+(** Decomposition of 32-bit integer constants.  They are split into either
+  small signed immediates that fit in 12-bits, or, if they do not fit,
+  into a (20-bit hi, 12-bit lo) pair where lo is sign-extended. *)
+
+*)
+Inductive immed32 : Type :=
+  | Imm32_single (imm: int).
+
+Definition make_immed32 (val: int) := Imm32_single val.
+
+(** Likewise, for 64-bit integer constants. *)
+Inductive immed64 : Type :=
+  | Imm64_single (imm: int64)
+.
+
+(* For now, let's suppose all instructions of K1c can handle 64-bits immediate *)
+Definition make_immed64 (val: int64) := Imm64_single val.
+
+Notation "a ::g b" := (cons (A:=instruction) a b) (at level 49, right associativity).
+Notation "a ::i b" := (cons (A:=basic) a b) (at level 49, right associativity).
+Notation "a ::b lb" := ((bblock_single_inst a) :: lb) (at level 49, right associativity).
+Notation "a ++g b" := (app (A:=instruction) a b) (at level 49, right associativity).
+
+(** Smart constructors for arithmetic operations involving
+  a 32-bit or 64-bit integer constant.  Depending on whether the
+  constant fits in 12 bits or not, one or several instructions
+  are generated as required to perform the operation
+  and prepended to the given instruction sequence [k]. *)
+
+Definition loadimm32 (r: ireg) (n: int) :=
+  match make_immed32 n with
+  | Imm32_single imm => Pmake r imm
+  end.
+
+Definition opimm32 (op: arith_name_rrr)
+                   (opimm: arith_name_rri32)
+                   (rd rs: ireg) (n: int) :=
+  match make_immed32 n with
+  | Imm32_single imm => opimm rd rs imm
+  end.
+
+Definition addimm32 := opimm32 Paddw Paddiw.
+Definition andimm32 := opimm32 Pandw Pandiw.
+Definition orimm32  := opimm32 Porw Poriw.
+Definition xorimm32 := opimm32 Pxorw Pxoriw.
+(*
+Definition sltimm32 := opimm32 Psltw Psltiw.
+Definition sltuimm32 := opimm32 Psltuw Psltiuw.
+*)
+
+Definition loadimm64 (r: ireg) (n: int64) :=
+  match make_immed64 n with
+  | Imm64_single imm => Pmakel r imm
+  end.
+
+Definition opimm64 (op: arith_name_rrr)
+                   (opimm: arith_name_rri64)
+                   (rd rs: ireg) (n: int64) :=
+  match make_immed64 n with
+  | Imm64_single imm => opimm rd rs imm
+end.
+
+Definition addimm64 := opimm64 Paddl Paddil.
+Definition orimm64  := opimm64 Porl  Poril.
+Definition andimm64 := opimm64 Pandl Pandil.
+Definition xorimm64 := opimm64 Pxorl  Pxoril.
+
+(*
+Definition sltimm64 := opimm64 Psltl Psltil.
+Definition sltuimm64 := opimm64 Psltul Psltiul.
+*)
+
+Definition cast32signed (rd rs: ireg) := 
+  if (ireg_eq rd rs)
+    then Pcvtw2l rd
+    else Pmvw2l rd rs
+  .
+
+Definition addptrofs (rd rs: ireg) (n: ptrofs) :=
+  if Ptrofs.eq_dec n Ptrofs.zero then
+    Pmv rd rs
+  else
+    addimm64 rd rs (Ptrofs.to_int64 n).
+
+(** Translation of conditional branches. *)
+
+Definition transl_comp
+    (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction :=
+  Pcompw (itest_for_cmp c s) RTMP r1 r2 ::g Pcb BTwnez RTMP lbl ::g k.
+
+Definition transl_compl
+    (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction :=
+  Pcompl (itest_for_cmp c s) RTMP r1 r2 ::g Pcb BTwnez RTMP lbl ::g k.
+
+Definition select_comp (n: int) (c: comparison) : option comparison :=
+  if Int.eq n Int.zero then
+    match c with
+    | Ceq => Some Ceq
+    | Cne => Some Cne
+    | _   => None
+    end
+  else
+    None
+  .
+
+Definition transl_opt_compuimm
+    (n: int) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction :=
+  if Int.eq n Int.zero then
+    match c with
+    | Ceq => Pcbu BTweqz r1 lbl ::g k
+    | Cne => Pcbu BTwnez r1 lbl ::g k
+    | _ => loadimm32 RTMP n ::g (transl_comp c Unsigned r1 RTMP lbl k)
+    end
+  else
+    loadimm32 RTMP n ::g (transl_comp c Unsigned r1 RTMP lbl k)
+  .
+
+(* Definition transl_opt_compuimm
+    (n: int) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction :=
+  loadimm32 RTMP n ::g (transl_comp c Unsigned r1 RTMP lbl k). *)
+
+(*   match select_comp n c with
+  | Some Ceq => Pcbu BTweqz r1 lbl ::g k
+  | Some Cne => Pcbu BTwnez r1 lbl ::g k
+  | Some _   => nil (* Never happens *)
+  | None     => loadimm32 RTMP n ::g (transl_comp c Unsigned r1 RTMP lbl k)
+  end
+  .
+ *)
+
+Definition select_compl (n: int64) (c: comparison) : option comparison :=
+  if Int64.eq n Int64.zero then
+    match c with
+    | Ceq => Some Ceq
+    | Cne => Some Cne
+    | _   => None
+    end
+  else
+    None
+  .
+
+Definition transl_opt_compluimm
+    (n: int64) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction :=
+  if Int64.eq n Int64.zero then
+    match c with
+    | Ceq => Pcbu BTdeqz r1 lbl ::g k
+    | Cne => Pcbu BTdnez r1 lbl ::g k
+    | _ => loadimm64 RTMP n ::g (transl_compl c Unsigned r1 RTMP lbl k)
+    end
+  else
+    loadimm64 RTMP n ::g (transl_compl c Unsigned r1 RTMP lbl k)
+  .
+
+(*   match select_compl n c with
+  | Some Ceq => Pcbu BTdeqz r1 lbl ::g k
+  | Some Cne => Pcbu BTdnez r1 lbl ::g k
+  | Some _   => nil (* Never happens *)
+  | None     => loadimm64 RTMP n ::g (transl_compl c Unsigned r1 RTMP lbl k)
+  end
+  .
+ *)
+
+Definition transl_cbranch
+    (cond: condition) (args: list mreg) (lbl: label) (k: code) : res (list instruction ) :=
+  match cond, args with
+  | Ccompuimm c n, a1 :: nil =>
+      do r1 <- ireg_of a1;
+      OK (transl_opt_compuimm n c r1 lbl k)
+  | Ccomp c, a1 :: a2 :: nil =>
+      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+      OK (transl_comp c Signed r1 r2 lbl k)
+  | Ccompu c, a1 :: a2 :: nil =>
+      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+      OK (transl_comp c Unsigned r1 r2 lbl k)
+  | Ccompimm c n, a1 :: nil =>
+      do r1 <- ireg_of a1;
+      OK (if Int.eq n Int.zero then
+            Pcb (btest_for_cmpswz c) r1 lbl ::g k
+          else
+            loadimm32 RTMP n ::g (transl_comp c Signed r1 RTMP lbl k)
+         )
+  | Ccompluimm c n, a1 :: nil =>
+      do r1 <- ireg_of a1;
+      OK (transl_opt_compluimm n c r1 lbl k)
+  | Ccompl c, a1 :: a2 :: nil =>
+      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+      OK (transl_compl c Signed r1 r2 lbl k)
+  | Ccomplu c, a1 :: a2 :: nil =>
+      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+      OK (transl_compl c Unsigned r1 r2 lbl k)
+  | Ccomplimm c n, a1 :: nil =>
+      do r1 <- ireg_of a1;
+      OK (if Int64.eq n Int64.zero then
+            Pcb (btest_for_cmpsdz c) r1 lbl ::g k
+          else
+            loadimm64 RTMP n ::g (transl_compl c Signed r1 RTMP lbl k)
+         )
+(*| Ccompf c, f1 :: f2 :: nil =>
+      do r1 <- freg_of f1; do r2 <- freg_of f2;
+      let (insn, normal) := transl_cond_float c rd r1 r2 in
+      OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k)
+  | Cnotcompf c, f1 :: f2 :: nil =>
+      do r1 <- freg_of f1; do r2 <- freg_of f2;
+      let (insn, normal) := transl_cond_float c rd r1 r2 in
+      OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k)
+  | Ccompfs c, f1 :: f2 :: nil =>
+      do r1 <- freg_of f1; do r2 <- freg_of f2;
+      let (insn, normal) := transl_cond_single c rd r1 r2 in
+      OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k)
+  | Cnotcompfs c, f1 :: f2 :: nil =>
+      do r1 <- freg_of f1; do r2 <- freg_of f2;
+      let (insn, normal) := transl_cond_single c rd r1 r2 in
+      OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k)
+*)| _, _ =>
+      Error(msg "Asmgen.transl_cbranch")
+  end.
+
+(** Translation of a condition operator.  The generated code sets the
+  [rd] target register to 0 or 1 depending on the truth value of the
+  condition. *)
+
+Definition transl_cond_int32s (cmp: comparison) (rd r1 r2: ireg) (k: bcode) :=
+  Pcompw (itest_for_cmp cmp Signed) rd r1 r2 ::i k.
+
+Definition transl_cond_int32u (cmp: comparison) (rd r1 r2: ireg) (k: bcode) :=
+  Pcompw (itest_for_cmp cmp Unsigned) rd r1 r2 ::i k.
+
+Definition transl_cond_int64s (cmp: comparison) (rd r1 r2: ireg) (k: bcode) :=
+  Pcompl (itest_for_cmp cmp Signed) rd r1 r2 ::i k.
+
+Definition transl_cond_int64u (cmp: comparison) (rd r1 r2: ireg) (k: bcode) :=
+  Pcompl (itest_for_cmp cmp Unsigned) rd r1 r2 ::i k.
+
+Definition transl_condimm_int32s (cmp: comparison) (rd r1: ireg) (n: int) (k: bcode) :=
+  Pcompiw (itest_for_cmp cmp Signed) rd r1 n ::i k.
+
+Definition transl_condimm_int32u (cmp: comparison) (rd r1: ireg) (n: int) (k: bcode) :=
+  Pcompiw (itest_for_cmp cmp Unsigned) rd r1 n ::i k.
+
+Definition transl_condimm_int64s (cmp: comparison) (rd r1: ireg) (n: int64) (k: bcode) :=
+  Pcompil (itest_for_cmp cmp Signed) rd r1 n ::i k.
+
+Definition transl_condimm_int64u (cmp: comparison) (rd r1: ireg) (n: int64) (k: bcode) :=
+  Pcompil (itest_for_cmp cmp Unsigned) rd r1 n ::i k.
+
+Definition transl_cond_op
+           (cond: condition) (rd: ireg) (args: list mreg) (k: bcode) :=
+  match cond, args with
+  | Ccomp c, a1 :: a2 :: nil =>
+      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+      OK (transl_cond_int32s c rd r1 r2 k)
+  | Ccompu c, a1 :: a2 :: nil =>
+      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+      OK (transl_cond_int32u c rd r1 r2 k)
+  | Ccompimm c n, a1 :: nil =>
+      do r1 <- ireg_of a1;
+      OK (transl_condimm_int32s c rd r1 n k)
+  | Ccompuimm c n, a1 :: nil =>
+      do r1 <- ireg_of a1;
+      OK (transl_condimm_int32u c rd r1 n k)
+  | Ccompl c, a1 :: a2 :: nil =>
+      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+      OK (transl_cond_int64s c rd r1 r2 k)
+  | Ccomplu c, a1 :: a2 :: nil =>
+      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+      OK (transl_cond_int64u c rd r1 r2 k)
+  | Ccomplimm c n, a1 :: nil =>
+      do r1 <- ireg_of a1;
+      OK (transl_condimm_int64s c rd r1 n k)
+  | Ccompluimm c n, a1 :: nil =>
+      do r1 <- ireg_of a1;
+      OK (transl_condimm_int64u c rd r1 n k)
+(*| Ccompf c, f1 :: f2 :: nil =>
+      do r1 <- freg_of f1; do r2 <- freg_of f2;
+      let (insn, normal) := transl_cond_float c rd r1 r2 in
+      OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k)
+  | Cnotcompf c, f1 :: f2 :: nil =>
+      do r1 <- freg_of f1; do r2 <- freg_of f2;
+      let (insn, normal) := transl_cond_float c rd r1 r2 in
+      OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k)
+  | Ccompfs c, f1 :: f2 :: nil =>
+      do r1 <- freg_of f1; do r2 <- freg_of f2;
+      let (insn, normal) := transl_cond_single c rd r1 r2 in
+      OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k)
+  | Cnotcompfs c, f1 :: f2 :: nil =>
+      do r1 <- freg_of f1; do r2 <- freg_of f2;
+      let (insn, normal) := transl_cond_single c rd r1 r2 in
+      OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k)
+*)| _, _ =>
+      Error(msg "Asmgen.transl_cond_op")
+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: bcode) :=
+  match op, args with
+  | Omove, a1 :: nil =>
+      match preg_of res, preg_of a1 with
+      | IR r, IR a => OK (Pmv r a ::i k)
+      |  _  ,  _   => Error(msg "Asmgen.Omove")
+      end
+  | Ointconst n, nil =>
+      do rd <- ireg_of res;
+      OK (loadimm32 rd n ::i k)
+  | Olongconst n, nil =>
+      do rd <- ireg_of res;
+      OK (loadimm64 rd n ::i k)
+(*| Ofloatconst f, nil =>
+      do rd <- freg_of res;
+      OK (if Float.eq_dec f Float.zero
+          then Pfcvtdw rd GPR0 :: k
+          else Ploadfi rd f :: k)
+  | Osingleconst f, nil =>
+      do rd <- freg_of res;
+      OK (if Float32.eq_dec f Float32.zero
+          then Pfcvtsw rd GPR0 :: k
+          else Ploadsi rd f :: k)
+*)| Oaddrsymbol s ofs, nil =>
+      do rd <- ireg_of res;
+      OK (if Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)
+          then Ploadsymbol s Ptrofs.zero rd ::i addptrofs rd rd ofs ::i k
+          else Ploadsymbol s ofs rd ::i k)
+  | Oaddrstack n, nil =>
+      do rd <- ireg_of res;
+      OK (addptrofs rd SP n ::i k)
+
+  | Ocast8signed, a1 :: nil =>
+      do rd <- ireg_of res; do rs <- ireg_of a1;
+      OK (Pslliw rd rs (Int.repr 24) ::i Psraiw rd rd (Int.repr 24) ::i k)
+  | Ocast16signed, a1 :: nil =>
+      do rd <- ireg_of res; do rs <- ireg_of a1;
+      OK (Pslliw rd rs (Int.repr 16) ::i Psraiw rd rd (Int.repr 16) ::i k)
+  | Oadd, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Paddw rd rs1 rs2 ::i k)
+  | Oaddimm n, a1 :: nil =>
+      do rd  <- ireg_of res; do rs <- ireg_of a1;
+      OK (addimm32 rd rs n ::i k)
+  | Oneg, a1 :: nil =>
+      do rd  <- ireg_of res; do rs <- ireg_of a1;
+      OK (Pnegw rd rs ::i k)
+  | Osub, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Psubw rd rs1 rs2 ::i k)
+  | Omul, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Pmulw rd rs1 rs2 ::i k)
+(*| Omulhs, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Pmulhw rd rs1 rs2 :: k)
+  | Omulhu, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Pmulhuw rd rs1 rs2 :: k)
+  | Odiv, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Pdivw rd rs1 rs2 :: k)
+  | Odivu, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Pdivuw rd rs1 rs2 :: k)
+  | Omod, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Premw rd rs1 rs2 :: k)
+  | Omodu, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Premuw rd rs1 rs2 :: k)
+*)| Oand, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Pandw rd rs1 rs2 ::i k)
+  | Oandimm n, a1 :: nil =>
+      do rd  <- ireg_of res; do rs <- ireg_of a1;
+      OK (andimm32 rd rs n ::i k)
+  | Oor, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Porw rd rs1 rs2 ::i k)
+  | Oorimm n, a1 :: nil =>
+      do rd  <- ireg_of res; do rs <- ireg_of a1;
+      OK (orimm32 rd rs n ::i k)
+  | Oxor, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Pxorw rd rs1 rs2 ::i k)
+  | Oxorimm n, a1 :: nil =>
+      do rd  <- ireg_of res; do rs <- ireg_of a1;
+      OK (xorimm32 rd rs n ::i k)
+  | Oshl, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Psllw rd rs1 rs2 ::i k)
+  | Oshlimm n, a1 :: nil =>
+      do rd <- ireg_of res; do rs <- ireg_of a1;
+      OK (Pslliw rd rs n ::i k)
+  | Oshr, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Psraw rd rs1 rs2 ::i k)
+  | Oshrimm n, a1 :: nil =>
+      do rd <- ireg_of res; do rs <- ireg_of a1;
+      OK (Psraiw rd rs n ::i k)
+  | Oshru, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Psrlw rd rs1 rs2 ::i k)
+  | Oshruimm n, a1 :: nil =>
+      do rd <- ireg_of res; do rs <- ireg_of a1;
+      OK (Psrliw rd rs n ::i k)
+  | Oshrximm n, a1 :: nil =>
+      do rd <- ireg_of res; do rs <- ireg_of a1;
+      OK (if Int.eq n Int.zero then Pmv rd rs ::i k else
+          Psraiw GPR31 rs (Int.repr 31) ::i
+          Psrliw GPR31 GPR31 (Int.sub Int.iwordsize n) ::i
+          Paddw GPR31 rs GPR31 ::i
+          Psraiw rd GPR31 n ::i k)
+
+  (* [Omakelong], [Ohighlong]  should not occur *)
+  | Olowlong, a1 :: nil =>
+      do rd <- ireg_of res; do rs <- ireg_of a1;
+      OK (Pcvtl2w rd rs ::i k)  
+  | Ocast32signed, a1 :: nil =>
+      do rd <- ireg_of res; do rs <- ireg_of a1;
+      OK (cast32signed rd rs ::i k)
+  | Ocast32unsigned, a1 :: nil =>
+      do rd <- ireg_of res; do rs <- ireg_of a1;
+      assertion (ireg_eq rd rs);
+      OK (Pcvtw2l rd ::i Psllil rd rd (Int.repr 32) ::i Psrlil rd rd (Int.repr 32) ::i k)
+  | Oaddl, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Paddl rd rs1 rs2 ::i k)
+  | Oaddlimm n, a1 :: nil =>
+      do rd  <- ireg_of res; do rs <- ireg_of a1;
+      OK (addimm64 rd rs n ::i k)
+  | Onegl, a1 :: nil =>
+      do rd  <- ireg_of res; do rs <- ireg_of a1;
+      OK (Pnegl rd rs ::i k)
+  | Osubl, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Psubl rd rs1 rs2 ::i k)
+  | Omull, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Pmull rd rs1 rs2 ::i k)
+(*| Omullhs, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Pmulhl rd rs1 rs2 :: k)
+  | Omullhu, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Pmulhul rd rs1 rs2 :: k)
+  | Odivl, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Pdivl rd rs1 rs2 :: k)
+  | Odivlu, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Pdivul rd rs1 rs2 :: k)
+  | Omodl, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Preml rd rs1 rs2 :: k)
+  | Omodlu, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Premul rd rs1 rs2 :: k)
+*)| Oandl, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Pandl rd rs1 rs2 ::i k)
+  | Oandlimm n, a1 :: nil =>
+      do rd  <- ireg_of res; do rs <- ireg_of a1;
+      OK (andimm64 rd rs n ::i k)
+  | Oorl, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Porl rd rs1 rs2 ::i k)
+  | Oorlimm n, a1 :: nil =>
+      do rd  <- ireg_of res; do rs <- ireg_of a1;
+      OK (orimm64 rd rs n ::i k)
+  | Oxorl, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Pxorl rd rs1 rs2 ::i k)
+  | Oxorlimm n, a1 :: nil =>
+      do rd  <- ireg_of res; do rs <- ireg_of a1;
+      OK (xorimm64 rd rs n ::i k)
+  | Oshll, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Pslll rd rs1 rs2 ::i k)
+  | Oshllimm n, a1 :: nil =>
+      do rd <- ireg_of res; do rs <- ireg_of a1;
+      OK (Psllil rd rs n ::i k)
+  | Oshrl, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Psral rd rs1 rs2 ::i k)
+  | Oshrlimm n, a1 :: nil =>
+      do rd <- ireg_of res; do rs <- ireg_of a1;
+      OK (Psrail rd rs n ::i k)
+  | Oshrlu, a1 :: a2 :: nil =>
+      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+      OK (Psrll rd rs1 rs2 ::i k)
+  | Oshrluimm n, a1 :: nil =>
+      do rd <- ireg_of res; do rs <- ireg_of a1;
+      OK (Psrlil rd rs n ::i k)
+(*| Oshrxlimm n, a1 :: nil =>
+      do rd <- ireg_of res; do rs <- ireg_of a1;
+      OK (if Int.eq n Int.zero then Pmv rd rs :: k else
+          Psrail GPR31 rs (Int.repr 63) ::
+          Psrlil GPR31 GPR31 (Int.sub Int64.iwordsize' n) ::
+          Paddl GPR31 rs GPR31 ::
+          Psrail rd GPR31 n :: k)
+
+*)| Onegf, a1 :: nil =>
+      do rd <- freg_of res; do rs <- freg_of a1;
+      OK (Pfnegd rd rs ::i k)
+(*| Oabsf, a1 :: nil =>
+      do rd <- freg_of res; do rs <- freg_of a1;
+      OK (Pfabsd rd rs :: k)
+  | Oaddf, a1 :: a2 :: nil =>
+      do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
+      OK (Pfaddd rd rs1 rs2 :: k)
+  | Osubf, a1 :: a2 :: nil =>
+      do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
+      OK (Pfsubd rd rs1 rs2 :: k)
+  | Omulf, a1 :: a2 :: nil =>
+      do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
+      OK (Pfmuld rd rs1 rs2 :: k)
+  | Odivf, a1 :: a2 :: nil =>
+      do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
+      OK (Pfdivd rd rs1 rs2 :: k)
+
+  | Onegfs, a1 :: nil =>
+      do rd <- freg_of res; do rs <- freg_of a1;
+      OK (Pfnegs rd rs :: k)
+  | Oabsfs, a1 :: nil =>
+      do rd <- freg_of res; do rs <- freg_of a1;
+      OK (Pfabss rd rs :: k)
+  | Oaddfs, a1 :: a2 :: nil =>
+      do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
+      OK (Pfadds rd rs1 rs2 :: k)
+  | Osubfs, a1 :: a2 :: nil =>
+      do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
+      OK (Pfsubs rd rs1 rs2 :: k)
+  | Omulfs, a1 :: a2 :: nil =>
+      do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
+      OK (Pfmuls rd rs1 rs2 :: k)
+  | Odivfs, a1 :: a2 :: nil =>
+      do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
+      OK (Pfdivs rd rs1 rs2 :: k)
+
+  | Osingleoffloat, a1 :: nil =>
+      do rd <- freg_of res; do rs <- freg_of a1;
+      OK (Pfcvtsd rd rs :: k)
+  | Ofloatofsingle, a1 :: nil =>
+      do rd <- freg_of res; do rs <- freg_of a1;
+      OK (Pfcvtds rd rs :: k)
+
+  | Ointoffloat, a1 :: nil =>
+      do rd <- ireg_of res; do rs <- freg_of a1;
+      OK (Pfcvtwd rd rs :: k)
+  | Ointuoffloat, a1 :: nil =>
+      do rd <- ireg_of res; do rs <- freg_of a1;
+      OK (Pfcvtwud rd rs :: k)
+  | Ofloatofint, a1 :: nil =>
+      do rd <- freg_of res; do rs <- ireg_of a1;
+      OK (Pfcvtdw rd rs :: k)
+  | Ofloatofintu, a1 :: nil =>
+      do rd <- freg_of res; do rs <- ireg_of a1;
+      OK (Pfcvtdwu rd rs :: k)
+  | Ointofsingle, a1 :: nil =>
+      do rd <- ireg_of res; do rs <- freg_of a1;
+      OK (Pfcvtws rd rs :: k)
+  | Ointuofsingle, a1 :: nil =>
+      do rd <- ireg_of res; do rs <- freg_of a1;
+      OK (Pfcvtwus rd rs :: k)
+  | Osingleofint, a1 :: nil =>
+      do rd <- freg_of res; do rs <- ireg_of a1;
+      OK (Pfcvtsw rd rs :: k)
+  | Osingleofintu, a1 :: nil =>
+      do rd <- freg_of res; do rs <- ireg_of a1;
+      OK (Pfcvtswu rd rs :: k)
+
+  | Olongoffloat, a1 :: nil =>
+      do rd <- ireg_of res; do rs <- freg_of a1;
+      OK (Pfcvtld rd rs :: k)
+  | Olonguoffloat, a1 :: nil =>
+      do rd <- ireg_of res; do rs <- freg_of a1;
+      OK (Pfcvtlud rd rs :: k)
+  | Ofloatoflong, a1 :: nil =>
+      do rd <- freg_of res; do rs <- ireg_of a1;
+      OK (Pfcvtdl rd rs :: k)
+  | Ofloatoflongu, a1 :: nil =>
+      do rd <- freg_of res; do rs <- ireg_of a1;
+      OK (Pfcvtdlu rd rs :: k)
+  | Olongofsingle, a1 :: nil =>
+      do rd <- ireg_of res; do rs <- freg_of a1;
+      OK (Pfcvtls rd rs :: k)
+  | Olonguofsingle, a1 :: nil =>
+      do rd <- ireg_of res; do rs <- freg_of a1;
+      OK (Pfcvtlus rd rs :: k)
+  | Osingleoflong, a1 :: nil =>
+      do rd <- freg_of res; do rs <- ireg_of a1;
+      OK (Pfcvtsl rd rs :: k)
+  | Osingleoflongu, a1 :: nil =>
+      do rd <- freg_of res; do rs <- ireg_of a1;
+      OK (Pfcvtslu rd rs :: k)
+
+*)| Ocmp cmp, _ =>
+      do rd <- ireg_of res;
+      transl_cond_op cmp rd args k
+  
+  | _, _ =>
+      Error(msg "Asmgen.transl_op")
+  end.
+
+(** Accessing data in the stack frame. *)
+
+Definition indexed_memory_access
+        (mk_instr: ireg -> offset -> basic)
+        (base: ireg) (ofs: ptrofs) :=
+  match make_immed64 (Ptrofs.to_int64 ofs) with
+  | Imm64_single imm =>
+      mk_instr base (Ofsimm (Ptrofs.of_int64 imm))
+(*| Imm64_pair hi lo =>
+      Pluil GPR31 hi :: Paddl GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm (Ptrofs.of_int64 lo)) :: k
+  | Imm64_large imm =>
+      Pmake GPR31 imm :: Paddl GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm Ptrofs.zero) :: k
+*)end.
+
+Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: bcode) :=
+  match ty, preg_of dst with
+  | Tint,    IR rd => OK (indexed_memory_access (Plw rd) base ofs ::i k)
+  | Tlong,   IR rd => OK (indexed_memory_access (Pld rd) base ofs ::i k)
+  | Tsingle, IR rd => OK (indexed_memory_access (Pfls rd) base ofs ::i k)
+  | Tfloat,  IR rd => OK (indexed_memory_access (Pfld rd) base ofs ::i k)
+  | Tany32,  IR rd => OK (indexed_memory_access (Plw_a rd) base ofs ::i k)
+  | Tany64,  IR rd => OK (indexed_memory_access (Pld_a rd) base ofs ::i k)
+  | _, _           => Error (msg "Asmgen.loadind")
+  end.
+
+Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: bcode) :=
+  match ty, preg_of src with
+  | Tint,    IR rd => OK (indexed_memory_access (Psw rd) base ofs ::i k)
+  | Tlong,   IR rd => OK (indexed_memory_access (Psd rd) base ofs ::i k)
+  | Tsingle, IR rd => OK (indexed_memory_access (Pfss rd) base ofs ::i k)
+  | Tfloat,  IR rd => OK (indexed_memory_access (Pfsd rd) base ofs ::i k)
+  | Tany32,  IR rd => OK (indexed_memory_access (Psw_a rd) base ofs ::i k)
+  | Tany64,  IR rd => OK (indexed_memory_access (Psd_a rd) base ofs ::i k)
+  | _, _           => Error (msg "Asmgen.storeind")
+  end.
+
+Definition loadind_ptr (base: ireg) (ofs: ptrofs) (dst: ireg) :=
+  indexed_memory_access (Pld dst) base ofs.
+
+Definition storeind_ptr (src: ireg) (base: ireg) (ofs: ptrofs) :=
+  indexed_memory_access (Psd src) base ofs.
+
+(** Translation of memory accesses: loads, and stores. *)
+
+Definition transl_memory_access
+     (mk_instr: ireg -> offset -> basic)
+     (addr: addressing) (args: list mreg) (k: bcode) : res bcode :=
+  match addr, args with
+  | Aindexed ofs, a1 :: nil =>
+      do rs <- ireg_of a1;
+      OK (indexed_memory_access mk_instr rs ofs ::i k)
+  | Aglobal id ofs, nil =>
+      OK (Ploadsymbol id ofs GPR31 ::i (mk_instr GPR31 (Ofsimm Ptrofs.zero) ::i k))
+  | Ainstack ofs, nil =>
+      OK (indexed_memory_access mk_instr SP ofs ::i k)
+  | _, _ =>
+      Error(msg "Asmgen.transl_memory_access")
+  end.
+
+Definition transl_load (chunk: memory_chunk) (addr: addressing)
+           (args: list mreg) (dst: mreg) (k: bcode) : res bcode :=
+  match chunk with
+  | Mint8signed =>
+      do r <- ireg_of dst;
+      transl_memory_access (Plb r)  addr args k
+  | Mint8unsigned =>
+      do r <- ireg_of dst;
+      transl_memory_access (Plbu r) addr args k
+  | Mint16signed =>
+      do r <- ireg_of dst;
+      transl_memory_access (Plh r)  addr args k
+  | Mint16unsigned =>
+      do r <- ireg_of dst;
+      transl_memory_access (Plhu r) addr args k
+  | Mint32 =>
+      do r <- ireg_of dst;
+      transl_memory_access (Plw r)  addr args k
+  | Mint64 =>
+      do r <- ireg_of dst;
+      transl_memory_access (Pld r)  addr args k
+  | Mfloat32 =>
+      do r <- freg_of dst;
+      transl_memory_access (Pfls r) addr args k
+  | Mfloat64 =>
+      do r <- freg_of dst;
+      transl_memory_access (Pfld r) addr args k
+  | _ =>
+      Error (msg "Asmgen.transl_load")
+  end.
+
+Definition transl_store (chunk: memory_chunk) (addr: addressing)
+           (args: list mreg) (src: mreg) (k: bcode) : res bcode :=
+  match chunk with
+  | Mint8signed | Mint8unsigned =>
+      do r <- ireg_of src;
+      transl_memory_access (Psb r)  addr args k
+  | Mint16signed | Mint16unsigned =>
+      do r <- ireg_of src;
+      transl_memory_access (Psh r)  addr args k
+  | Mint32 =>
+      do r <- ireg_of src;
+      transl_memory_access (Psw r)  addr args k
+  | Mint64 =>
+      do r <- ireg_of src;
+      transl_memory_access (Psd r)  addr args k
+  | Mfloat32 =>
+      do r <- freg_of src;
+      transl_memory_access (Pfss r) addr args k
+  | Mfloat64 =>
+      do r <- freg_of src;
+      transl_memory_access (Pfsd r) addr args k
+  | _ =>
+      Error (msg "Asmgen.transl_store")
+  end.
+
+(** Function epilogue *)
+
+Definition make_epilogue (f: Machblock.function) (k: code) :=
+  (loadind_ptr SP f.(fn_retaddr_ofs) GPR8) 
+  ::g Pset RA GPR8 ::g Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) ::g k.
+
+(** Translation of a Mach instruction. *)
+
+Definition transl_instr_basic (f: Machblock.function) (i: Machblock.basic_inst)
+                              (ep: bool) (k: bcode) :=
+  match i with
+  | MBgetstack ofs ty dst =>
+      loadind SP ofs ty dst k
+  | MBsetstack src ofs ty =>
+      storeind src SP ofs ty k
+  | MBgetparam ofs ty dst =>
+      (* load via the frame pointer if it is valid *)
+      do c <- loadind FP ofs ty dst k;
+      OK (if ep then c
+                else (loadind_ptr SP f.(fn_link_ofs) FP) ::i c)
+  | MBop op args res =>
+      transl_op op args res k
+  | MBload chunk addr args dst =>
+      transl_load chunk addr args dst k
+  | MBstore chunk addr args src =>
+      transl_store chunk addr args src k
+  end.
+
+Definition transl_instr_control (f: Machblock.function) (oi: option Machblock.control_flow_inst)
+                                : res code :=
+  match oi with
+  | None => OK nil
+  | Some i =>
+    match i with
+(*| Mcall sig (inl r) =>
+      do r1 <- ireg_of r; OK (Pjal_r r1 sig :: k)
+*)  | MBcall sig (inr symb) =>
+        OK ((Pcall symb) ::g nil)
+(*| Mtailcall sig (inl r) =>
+      do r1 <- ireg_of r;
+      OK (make_epilogue f (Pcall :: k))
+*)  | MBtailcall sig (inr symb) =>
+        OK (make_epilogue f ((Pgoto symb) ::g nil))
+    | MBbuiltin ef args res =>
+        OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) ::g nil)
+(*   | Mlabel lbl =>
+      OK (Plabel lbl ::i k) *)
+    | MBgoto lbl =>
+        OK (Pj_l lbl ::g nil)
+    | MBcond cond args lbl =>
+        transl_cbranch cond args lbl nil
+(*| Mjumptable arg tbl => do r <- ireg_of arg; OK (Pbtbl r tbl :: k)
+*)  | MBreturn =>
+        OK (make_epilogue f (Pret ::g nil))
+      (*OK (make_epilogue f (Pj_r RA f.(Mach.fn_sig) :: k))*)
+    | _ =>
+        Error (msg "Asmgen.transl_instr")
+    end
+  end.
+
+(* TODO - dans l'idée, transl_instr_control renvoie une liste d'instructions sous la forme :
+  * transl_instr_control _ _ _ = lb ++ (ctl :: nil), où lb est une liste de basics, ctl est un control_inst
+
+  Il faut arriver à exprimer cet aspect là ; extraire le lb, le rajouter dans le body ; et extraire le ctl
+  qu'on met dans le exit
+*)
+
+(** Translation of a code sequence *)
+
+Definition fp_is_parent (before: bool) (i: Machblock.basic_inst) : bool :=
+  match i with
+  | MBsetstack src ofs ty => before
+  | MBgetparam ofs ty dst => negb (mreg_eq dst R10)
+  | MBop op args res => before && negb (mreg_eq res R10)
+  | _ => 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_basic_code (f: Machblock.function) (il: list Machblock.basic_inst) (it1p: bool) :=
+  match il with
+  | nil => OK nil
+  | i1 :: il' =>
+      do k <- transl_basic_code f il' (fp_is_parent it1p i1);
+      transl_instr_basic f i1 it1p k
+  end.
+
+(* (** This is an equivalent definition in continuation-passing style
+  that runs in constant stack space. *)
+
+Fixpoint transl_basic_rec (f: Machblock.function) (il: list Machblock.basic_inst)
+                          (it1p: bool) (k: bcode -> res bcode) :=
+  match il with
+  | nil => k nil
+  | i1 :: il' =>
+      transl_basic_rec f il' (fp_is_parent it1p i1)
+        (fun c1 => do c2 <- transl_instr_basic f i1 it1p c1; k c2)
+  end.
+
+Definition transl_basic_code' (f: Machblock.function) (il: list Machblock.basic_inst) (it1p: bool) :=
+  transl_basic_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. *)
+
+(* Local Obligation Tactic := bblock_auto_correct. *)
+
+(* Program Definition gen_bblock_noctl (hd: list label) (c: list basic) :=
+  match c with
+  | nil => {| header := hd; body := Pnop::nil; exit := None |}
+  | i::c => {| header := hd; body := i::c; exit := None |}
+  end.
+ *)
+
+(** Can generate two bblocks if the ctl is a PExpand (since the PExpand must be alone in its block) *)
+Program Definition gen_bblocks (hd: list label) (c: list basic) (ctl: list instruction) :=
+  match (extract_ctl ctl) with
+  | None => 
+      match c with
+      | nil => {| header := hd; body := Pnop::nil; exit := None |} :: nil
+      | i::c => {| header := hd; body := ((i::c) ++ extract_basic ctl); exit := None |} :: nil
+      end
+(* gen_bblock_noctl hd (c ++ (extract_basic ctl)) :: nil *)
+  | Some (PExpand (Pbuiltin ef args res)) =>
+      match c with
+      | nil => {| header := hd; body := nil; exit := Some (PExpand (Pbuiltin ef args res)) |} :: nil
+      | _ => {| header := hd; body := c; exit := None |} 
+              :: {| header := nil; body := nil; exit := Some (PExpand (Pbuiltin ef args res)) |} :: nil
+      end
+  | Some (PCtlFlow i) => {| header := hd; body := (c ++ extract_basic ctl); exit := Some (PCtlFlow i) |} :: nil
+  end
+.
+Next Obligation.
+  bblock_auto_correct. intros. constructor. apply not_eq_sym. auto.
+Qed. Next Obligation.
+  bblock_auto_correct.
+Qed.
+
+Definition transl_block (f: Machblock.function) (fb: Machblock.bblock) (ep: bool) : res (list bblock) :=
+  do c <- transl_basic_code f fb.(Machblock.body) ep;
+  do ctl <- transl_instr_control f fb.(Machblock.exit);
+  OK (gen_bblocks fb.(Machblock.header) c ctl)
+.
+
+Fixpoint transl_blocks (f: Machblock.function) (lmb: list Machblock.bblock) (ep: bool) :=
+  match lmb with
+  | nil => OK nil
+  | mb :: lmb => 
+      do lb <- transl_block f mb (if Machblock.header mb then ep else false);
+      do lb' <- transl_blocks f lmb false;
+      OK (lb ++ lb')
+  end
+.
+
+Definition transl_function (f: Machblock.function) :=
+  do lb <- transl_blocks f f.(Machblock.fn_code) true;
+  OK (mkfunction f.(Machblock.fn_sig)
+        (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::b
+         Pget GPR8 RA ::b
+         storeind_ptr GPR8 SP f.(fn_retaddr_ofs) ::b lb)).
+
+Fixpoint size_blocks (l: bblocks): Z :=
+  match l with
+  | nil => 0
+  | b :: l =>
+     (size b) + (size_blocks l)
+  end
+  .
+
+Definition transf_function (f: Machblock.function) : res Asmblock.function :=
+  do tf <- transl_function f;
+  if zlt Ptrofs.max_unsigned (size_blocks tf.(fn_blocks))
+  then Error (msg "code size exceeded")
+  else OK tf.
+
+
+Definition transf_fundef (f: Machblock.fundef) : res Asmblock.fundef :=
+  transf_partial_fundef transf_function f.
+
+Definition transf_program (p: Machblock.program) : res Asmblock.program :=
+  transform_partial_program transf_fundef p.
diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v
new file mode 100644
index 00000000..ee18e5e3
--- /dev/null
+++ b/mppa_k1c/Asmblockgenproof.v
@@ -0,0 +1,2143 @@
+(* *********************************************************************)

+(*                                                                     *)

+(*              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.     *)

+(*                                                                     *)

+(* *********************************************************************)

+

+(** Correctness proof for RISC-V generation: main proof. *)

+

+Require Import Coqlib Errors.

+Require Import Integers Floats AST Linking.

+Require Import Values Memory Events Globalenvs Smallstep.

+Require Import Op Locations Machblock Conventions Asmblock.

+(* Require Import Asmgen Asmgenproof0 Asmgenproof1. *)

+Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1.

+

+Module MB := Machblock.

+Module AB := Asmblock.

+

+Definition match_prog (p: Machblock.program) (tp: Asmblock.program) :=

+  match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp.

+

+Lemma transf_program_match:

+  forall p tp, transf_program p = OK tp -> match_prog p tp.

+Proof.

+  intros. eapply match_transform_partial_program; eauto.

+Qed.

+

+Section PRESERVATION.

+

+Variable prog: Machblock.program.

+Variable tprog: Asmblock.program.

+Hypothesis TRANSF: match_prog prog tprog.

+Let ge := Genv.globalenv prog.

+Let tge := Genv.globalenv tprog.

+

+Lemma symbols_preserved:

+  forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.

+Proof (Genv.find_symbol_match TRANSF).

+

+Lemma senv_preserved:

+  Senv.equiv ge tge.

+Proof (Genv.senv_match TRANSF).

+

+

+Lemma functions_translated:

+  forall b f,

+  Genv.find_funct_ptr ge b = Some f ->

+  exists tf,

+  Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf.

+Proof (Genv.find_funct_ptr_transf_partial TRANSF).

+

+Lemma functions_transl:

+  forall fb f tf,

+  Genv.find_funct_ptr ge fb = Some (Internal f) ->

+  transf_function f = OK tf ->

+  Genv.find_funct_ptr tge fb = Some (Internal tf).

+Proof.

+  intros. exploit functions_translated; eauto. intros [tf' [A B]].

+  monadInv B. rewrite H0 in EQ; inv EQ; auto.

+Qed.

+

+(** * Properties of control flow *)

+

+Lemma transf_function_no_overflow:

+  forall f tf,

+  transf_function f = OK tf -> size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned.

+Proof.

+  intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0.

+  omega.

+Qed.

+

+(*

+Lemma exec_straight_exec:

+  forall fb f c ep tf tc c' rs m rs' m',

+  transl_code_at_pc ge (rs PC) fb f c ep tf tc ->

+  exec_straight tge tf tc rs m c' rs' m' ->

+  plus step tge (State rs m) E0 (State rs' m').

+Proof.

+  intros. inv H.

+  eapply exec_straight_steps_1; eauto.

+  eapply transf_function_no_overflow; eauto.

+  eapply functions_transl; eauto.

+Qed.

+

+Lemma exec_straight_at:

+  forall fb f c ep tf tc c' ep' tc' rs m rs' m',

+  transl_code_at_pc ge (rs PC) fb f c ep tf tc ->

+  transl_code f c' ep' = OK tc' ->

+  exec_straight tge tf tc rs m tc' rs' m' ->

+  transl_code_at_pc ge (rs' PC) fb f c' ep' tf tc'.

+Proof.

+  intros. inv H.

+  exploit exec_straight_steps_2; eauto.

+  eapply transf_function_no_overflow; eauto.

+  eapply functions_transl; eauto.

+  intros [ofs' [PC' CT']].

+  rewrite PC'. constructor; auto.

+Qed.

+ *)

+(** The following lemmas show that the translation from Mach to Asm

+  preserves labels, in the sense that the following diagram commutes:

+<<

+                          translation

+        Mach code ------------------------ Asm instr sequence

+            |                                          |

+            | Mach.find_label lbl       find_label lbl |

+            |                                          |

+            v                                          v

+        Mach code tail ------------------- Asm instr seq tail

+                          translation

+>>

+  The proof demands many boring lemmas showing that Asm constructor

+  functions do not introduce new labels.

+*)

+

+Section TRANSL_LABEL.

+

+(* Remark loadimm32_label:

+  forall r n k, tail_nolabel k (loadimm32 r n k).

+Proof.

+  intros; unfold loadimm32. destruct (make_immed32 n); TailNoLabel.

+(*unfold load_hilo32. destruct (Int.eq lo Int.zero); TailNoLabel.*)

+Qed.

+Hint Resolve loadimm32_label: labels.

+

+Remark opimm32_label:

+  forall (op: arith_name_rrr) (opimm: arith_name_rri32) r1 r2 n k,

+  (forall r1 r2 r3, nolabel (op r1 r2 r3)) ->

+  (forall r1 r2 n, nolabel (opimm r1 r2 n)) ->

+  tail_nolabel k (opimm32 op opimm r1 r2 n k).

+Proof.

+  intros; unfold opimm32. destruct (make_immed32 n); TailNoLabel.

+(*unfold load_hilo32. destruct (Int.eq lo Int.zero); TailNoLabel.*)

+Qed.

+Hint Resolve opimm32_label: labels.

+

+Remark loadimm64_label:

+  forall r n k, tail_nolabel k (loadimm64 r n k).

+Proof.

+  intros; unfold loadimm64. destruct (make_immed64 n); TailNoLabel.

+(*unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel.*)

+Qed.

+Hint Resolve loadimm64_label: labels.

+

+Remark cast32signed_label:

+  forall rd rs k, tail_nolabel k (cast32signed rd rs k).

+Proof.

+  intros; unfold cast32signed. destruct (ireg_eq rd rs); TailNoLabel.

+Qed.

+Hint Resolve cast32signed_label: labels.

+

+Remark opimm64_label:

+  forall (op: arith_name_rrr) (opimm: arith_name_rri64) r1 r2 n k,

+  (forall r1 r2 r3, nolabel (op r1 r2 r3)) ->

+  (forall r1 r2 n, nolabel (opimm r1 r2 n)) ->

+  tail_nolabel k (opimm64 op opimm r1 r2 n k).

+Proof.

+  intros; unfold opimm64. destruct (make_immed64 n); TailNoLabel.

+(*unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel.*)

+Qed.

+Hint Resolve opimm64_label: labels.

+

+Remark addptrofs_label:

+  forall r1 r2 n k, tail_nolabel k (addptrofs r1 r2 n k).

+Proof.

+  unfold addptrofs; intros. destruct (Ptrofs.eq_dec n Ptrofs.zero). TailNoLabel.

+  apply opimm64_label; TailNoLabel.

+Qed.

+Hint Resolve addptrofs_label: labels.

+(*

+Remark transl_cond_float_nolabel:

+  forall c r1 r2 r3 insn normal,

+  transl_cond_float c r1 r2 r3 = (insn, normal) -> nolabel insn.

+Proof.

+  unfold transl_cond_float; intros. destruct c; inv H; exact I.

+Qed.

+

+Remark transl_cond_single_nolabel:

+  forall c r1 r2 r3 insn normal,

+  transl_cond_single c r1 r2 r3 = (insn, normal) -> nolabel insn.

+Proof.

+  unfold transl_cond_single; intros. destruct c; inv H; exact I.

+Qed.

+*)

+Remark transl_cbranch_label:

+  forall cond args lbl k c,

+  transl_cbranch cond args lbl k = OK c -> tail_nolabel k c.

+Proof.

+  intros. unfold transl_cbranch in H. destruct cond; TailNoLabel.

+(* Ccomp *)

+  - unfold transl_comp; TailNoLabel.

+(* Ccompu *)

+  - unfold transl_comp; TailNoLabel.

+(* Ccompimm *)

+  - destruct (Int.eq n Int.zero); TailNoLabel.

+    unfold loadimm32. destruct (make_immed32 n); TailNoLabel. unfold transl_comp; TailNoLabel.

+(* Ccompuimm *)

+  - unfold transl_opt_compuimm.

+    remember (select_comp n c0) as selcomp; destruct selcomp.

+    + destruct c; TailNoLabel; contradict Heqselcomp; unfold select_comp;

+      destruct (Int.eq n Int.zero); destruct c0; discriminate.

+    + unfold loadimm32;

+      destruct (make_immed32 n); TailNoLabel; unfold transl_comp; TailNoLabel.

+(* Ccompl *)

+  - unfold transl_compl; TailNoLabel.

+(* Ccomplu *)

+  - unfold transl_compl; TailNoLabel.

+(* Ccomplimm *)

+  - destruct (Int64.eq n Int64.zero); TailNoLabel.

+    unfold loadimm64. destruct (make_immed64 n); TailNoLabel. unfold transl_compl; TailNoLabel.

+(* Ccompluimm *)

+  - unfold transl_opt_compluimm.

+    remember (select_compl n c0) as selcomp; destruct selcomp.

+    + destruct c; TailNoLabel; contradict Heqselcomp; unfold select_compl;

+      destruct (Int64.eq n Int64.zero); destruct c0; discriminate.

+    + unfold loadimm64;

+      destruct (make_immed64 n); TailNoLabel; unfold transl_compl; TailNoLabel.

+Qed.

+

+(*

+- destruct c0; simpl; TailNoLabel.

+- destruct c0; simpl; TailNoLabel.

+- destruct (Int.eq n Int.zero).

+  destruct c0; simpl; TailNoLabel.

+  apply tail_nolabel_trans with (transl_cbranch_int32s c0 x X31 lbl :: k).

+  auto with labels. destruct c0; simpl; TailNoLabel.

+- destruct (Int.eq n Int.zero).

+  destruct c0; simpl; TailNoLabel.

+  apply tail_nolabel_trans with (transl_cbranch_int32u c0 x X31 lbl :: k).

+  auto with labels. destruct c0; simpl; TailNoLabel.

+- destruct c0; simpl; TailNoLabel.

+- destruct c0; simpl; TailNoLabel.

+- destruct (Int64.eq n Int64.zero).

+  destruct c0; simpl; TailNoLabel.

+  apply tail_nolabel_trans with (transl_cbranch_int64s c0 x X31 lbl :: k).

+  auto with labels. destruct c0; simpl; TailNoLabel.

+- destruct (Int64.eq n Int64.zero).

+  destruct c0; simpl; TailNoLabel.

+  apply tail_nolabel_trans with (transl_cbranch_int64u c0 x X31 lbl :: k).

+  auto with labels. destruct c0; simpl; TailNoLabel.

+- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:F; inv EQ2.

+  apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. 

+  destruct normal; TailNoLabel.

+- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:F; inv EQ2.

+  apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. 

+  destruct normal; TailNoLabel.

+- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2.

+  apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. 

+  destruct normal; TailNoLabel.

+- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2.

+  apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. 

+  destruct normal; TailNoLabel.

+*)

+

+Remark transl_cond_op_label:

+  forall cond args r k c,

+  transl_cond_op cond r args k = OK c -> tail_nolabel k c.

+Proof.

+  intros. unfold transl_cond_op in H; destruct cond; TailNoLabel.

+- unfold transl_cond_int32s; destruct c0; simpl; TailNoLabel.

+- unfold transl_cond_int32u; destruct c0; simpl; TailNoLabel. 

+- unfold transl_condimm_int32s; destruct c0; simpl; TailNoLabel.

+- unfold transl_condimm_int32u; destruct c0; simpl; TailNoLabel.

+- unfold transl_cond_int64s; destruct c0; simpl; TailNoLabel.

+- unfold transl_cond_int64u; destruct c0; simpl; TailNoLabel. 

+- unfold transl_condimm_int64s; destruct c0; simpl; TailNoLabel.

+- unfold transl_condimm_int64u; destruct c0; simpl; TailNoLabel.

+Qed.

+

+Remark transl_op_label:

+  forall op args r k c,

+  transl_op op args r k = OK c -> tail_nolabel k c.

+Proof.

+Opaque Int.eq.

+  unfold transl_op; intros; destruct op; TailNoLabel.

+(* Omove *)

+- destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel.

+(* Oaddrsymbol *)

+- destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)); TailNoLabel.

+(* Oaddimm32 *)

+- apply opimm32_label; intros; exact I.

+(* Oandimm32 *)

+- apply opimm32_label; intros; exact I.

+(* Oorimm32 *)

+- apply opimm32_label; intros; exact I.

+(* Oxorimm32 *)

+- apply opimm32_label; intros; exact I.

+(* Oshrximm *)

+- destruct (Int.eq n Int.zero); TailNoLabel.

+(* Oaddimm64 *)

+- apply opimm64_label; intros; exact I.

+(* Oandimm64  *)

+- apply opimm64_label; intros; exact I.

+(* Oorimm64  *)

+- apply opimm64_label; intros; exact I.

+(* Oxorimm64  *)

+- apply opimm64_label; intros; exact I.

+(* Ocmp *)

+- eapply transl_cond_op_label; eauto.

+Qed.

+

+(*

+- destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel.

+- destruct (Float.eq_dec n Float.zero); TailNoLabel.

+- destruct (Float32.eq_dec n Float32.zero); TailNoLabel.

+- destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)).

++ eapply tail_nolabel_trans; [|apply addptrofs_label]. TailNoLabel.

++ TailNoLabel. 

+- apply opimm32_label; intros; exact I.

+- apply opimm32_label; intros; exact I.

+- apply opimm32_label; intros; exact I.

+- apply opimm32_label; intros; exact I.

+- destruct (Int.eq n Int.zero); TailNoLabel.

+- apply opimm64_label; intros; exact I.

+- apply opimm64_label; intros; exact I.

+- apply opimm64_label; intros; exact I.

+- apply opimm64_label; intros; exact I.

+- destruct (Int.eq n Int.zero); TailNoLabel.

+- eapply transl_cond_op_label; eauto.

+*)

+*)

+

+(* Remark indexed_memory_access_label:

+  forall (mk_instr: ireg -> offset -> instruction) base ofs k,

+  (forall r o, nolabel (mk_instr r o)) ->

+  tail_nolabel k (indexed_memory_access mk_instr base ofs k).

+Proof.

+  unfold indexed_memory_access; intros. 

+  (* destruct Archi.ptr64. *)

+  destruct (make_immed64 (Ptrofs.to_int64 ofs)); TailNoLabel.

+  (* destruct (make_immed32 (Ptrofs.to_int ofs)); TailNoLabel. *)

+Qed. *)

+

+(*

+Remark loadind_label:

+  forall base ofs ty dst k c,

+  loadind base ofs ty dst k = OK c -> tail_nolabel k c.

+Proof.

+  unfold loadind; intros.

+  destruct ty, (preg_of dst); inv H; apply indexed_memory_access_label; intros; exact I.

+Qed.

+

+Remark storeind_label:

+  forall src base ofs ty k c,

+  storeind src base ofs ty k = OK c -> tail_nolabel k c.

+Proof.

+  unfold storeind; intros.

+  destruct ty, (preg_of src); inv H; apply indexed_memory_access_label; intros; exact I.

+Qed.

+

+Remark loadind_ptr_label:

+  forall base ofs dst k, tail_nolabel k (loadind_ptr base ofs dst k).

+Proof.

+  intros. apply indexed_memory_access_label. intros; destruct Archi.ptr64; exact I.

+Qed.

+*)

+

+(* Remark storeind_ptr_label:

+  forall src base ofs k, tail_nolabel k (storeind_ptr src base ofs k).

+Proof.

+  intros. apply indexed_memory_access_label. intros; destruct Archi.ptr64; exact I.

+Qed. *)

+

+(*

+Remark transl_memory_access_label:

+  forall (mk_instr: ireg -> offset -> instruction) addr args k c,

+  (forall r o, nolabel (mk_instr r o)) ->

+  transl_memory_access mk_instr addr args k = OK c ->

+  tail_nolabel k c.

+Proof.

+  unfold transl_memory_access; intros; destruct addr; TailNoLabel; apply indexed_memory_access_label; auto. 

+Qed.

+

+Remark make_epilogue_label:

+  forall f k, tail_nolabel k (make_epilogue f k).

+Proof.

+  unfold make_epilogue; intros. eapply tail_nolabel_trans. apply loadind_ptr_label. TailNoLabel.

+Qed.

+

+Lemma transl_instr_label:

+  forall f i ep k c,

+  transl_instr f i ep k = OK c ->

+  match i with Mlabel lbl => c = Plabel lbl ::i k | _ => tail_nolabel k c end.

+Proof.

+  unfold transl_instr; intros; destruct i; TailNoLabel.

+(* loadind *)

+- eapply loadind_label; eauto.

+(* storeind *)

+- eapply storeind_label; eauto.

+(* Mgetparam *)

+- destruct ep. eapply loadind_label; eauto.

+  eapply tail_nolabel_trans. apply loadind_ptr_label. eapply loadind_label; eauto. 

+(* transl_op *)

+- eapply transl_op_label; eauto.

+(* transl_load *)

+- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I.

+(* transl store *)

+- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I.

+- destruct s0; monadInv H; TailNoLabel.

+- destruct s0; monadInv H; eapply tail_nolabel_trans

+  ; [eapply make_epilogue_label|TailNoLabel].

+- eapply transl_cbranch_label; eauto.

+- eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel].

+Qed.

+(*

+

+

+- eapply transl_op_label; eauto.

+- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I.

+- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I.

+- destruct s0; monadInv H; (eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]).

+- eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel].

+*)

+

+Lemma transl_instr_label':

+  forall lbl f i ep k c,

+  transl_instr f i ep k = OK c ->

+  find_label lbl c = if Mach.is_label lbl i then Some k else find_label lbl k.

+Proof.

+  intros. exploit transl_instr_label; eauto.

+  destruct i; try (intros [A B]; apply B).

+  intros. subst c. simpl. auto.

+Qed.

+*)

+

+Lemma gen_bblocks_label:

+  forall hd bdy ex tbb tc,

+  gen_bblocks hd bdy ex = tbb::tc ->

+  header tbb = hd.

+Proof.

+  intros until tc. intros GENB. unfold gen_bblocks in GENB.

+  destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy.

+  all: inv GENB; simpl; auto.

+Qed.

+

+Lemma gen_bblocks_label2:

+  forall hd bdy ex tbb1 tbb2,

+  gen_bblocks hd bdy ex = tbb1::tbb2::nil ->

+  header tbb2 = nil.

+Proof.

+  intros until tbb2. intros GENB. unfold gen_bblocks in GENB.

+  destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy.

+  all: inv GENB; simpl; auto.

+Qed.

+

+Lemma in_dec_transl:

+  forall lbl hd,

+  (if in_dec lbl hd then true else false) = (if MB.in_dec lbl hd then true else false).

+Proof.

+  intros. destruct (in_dec lbl hd), (MB.in_dec lbl hd). all: tauto.

+Qed.

+

+Lemma transl_is_label:

+  forall lbl bb tbb f ep tc,

+  transl_block f bb ep = OK (tbb::tc) ->

+  is_label lbl tbb = MB.is_label lbl bb.

+Proof.

+  intros until tc. intros TLB.

+  destruct tbb as [thd tbdy tex]; simpl in *.

+  monadInv TLB.

+  unfold is_label. simpl.

+  apply gen_bblocks_label in H0. simpl in H0. subst.

+  rewrite in_dec_transl. auto.

+Qed.

+

+Lemma transl_is_label_false2:

+  forall lbl bb f ep tbb1 tbb2,

+  transl_block f bb ep = OK (tbb1::tbb2::nil) ->

+  is_label lbl tbb2 = false.

+Proof.

+  intros until tbb2. intros TLB.

+  destruct tbb2 as [thd tbdy tex]; simpl in *.

+  monadInv TLB. apply gen_bblocks_label2 in H0. simpl in H0. subst.

+  apply is_label_correct_false. simpl. auto.

+Qed.

+

+Lemma transl_is_label2:

+  forall f bb ep tbb1 tbb2 lbl,

+  transl_block f bb ep = OK (tbb1::tbb2::nil) ->

+     is_label lbl tbb1 = MB.is_label lbl bb

+  /\ is_label lbl tbb2 = false.

+Proof.

+  intros. split. eapply transl_is_label; eauto. eapply transl_is_label_false2; eauto.

+Qed.

+

+Lemma transl_block_nonil:

+  forall f c ep tc,

+  transl_block f c ep = OK tc ->

+  tc <> nil.

+Proof.

+  intros. monadInv H. unfold gen_bblocks.

+  destruct (extract_ctl x0); try destruct c0; try destruct x; try destruct i.

+  all: discriminate.

+Qed.

+

+Lemma transl_block_limit: forall f bb ep tbb1 tbb2 tbb3 tc,

+  ~transl_block f bb ep = OK (tbb1 :: tbb2 :: tbb3 :: tc).

+Proof.

+  intros. intro. monadInv H.

+  unfold gen_bblocks in H0.

+  destruct (extract_ctl x0); try destruct x; try destruct c; try destruct i.

+  all: discriminate.

+Qed.

+

+Lemma find_label_transl_false:

+  forall x f lbl bb ep x',

+  transl_block f bb ep = OK x ->

+  MB.is_label lbl bb = false ->

+  find_label lbl (x++x') = find_label lbl x'.

+Proof.

+  intros until x'. intros TLB MBis; simpl; auto.

+  destruct x as [|x0 x1]; simpl; auto.

+  destruct x1 as [|x1 x2]; simpl; auto.

+  - erewrite <- transl_is_label in MBis; eauto. rewrite MBis. auto.

+  - destruct x2 as [|x2 x3]; simpl; auto.

+    + erewrite <- transl_is_label in MBis; eauto. rewrite MBis.

+      erewrite transl_is_label_false2; eauto.

+    + apply transl_block_limit in TLB. destruct TLB.

+Qed.

+

+Lemma transl_blocks_label:

+  forall lbl f c tc ep,

+  transl_blocks f c ep = OK tc ->

+  match MB.find_label lbl c with

+  | None => find_label lbl tc = None

+  | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_blocks f c' false = OK tc'

+  end.

+Proof.

+  induction c; simpl; intros.

+  inv H. auto.

+  monadInv H.

+  destruct (MB.is_label lbl a) eqn:MBis.

+  - destruct x as [|tbb tc]. { apply transl_block_nonil in EQ. contradiction. }

+    simpl find_label. exploit transl_is_label; eauto. intros ABis. rewrite MBis in ABis.

+    rewrite ABis.

+    eexists. eexists. split; eauto. simpl transl_blocks.

+    assert (MB.header a <> nil).

+    { apply MB.is_label_correct_true in MBis.

+      destruct (MB.header a). contradiction. discriminate. }

+    destruct (MB.header a); try contradiction.

+    rewrite EQ. simpl. rewrite EQ1. simpl. auto.

+  - apply IHc in EQ1. destruct (MB.find_label lbl c).

+    + destruct EQ1 as (tc' & FIND & TLBS). exists tc'; eexists; auto.

+      erewrite find_label_transl_false; eauto.

+    + erewrite find_label_transl_false; eauto.

+Qed.

+

+Lemma find_label_nil:

+  forall bb lbl c,

+  header bb = nil ->

+  find_label lbl (bb::c) = find_label lbl c.

+Proof.

+  intros. destruct bb as [hd bdy ex]; simpl in *. subst.

+  assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false).

+  { erewrite <- is_label_correct_false. simpl. auto. }

+  rewrite H. auto.

+Qed.

+

+Lemma transl_find_label:

+  forall lbl f tf,

+  transf_function f = OK tf ->

+  match MB.find_label lbl f.(MB.fn_code) with

+  | None => find_label lbl tf.(fn_blocks) = None

+  | Some c => exists tc, find_label lbl tf.(fn_blocks) = Some tc /\ transl_blocks f c false = OK tc

+  end.

+Proof.

+  intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks x))); inv EQ0. clear g.

+  monadInv EQ. simpl fn_blocks. repeat (rewrite find_label_nil); simpl; auto.

+  eapply transl_blocks_label; eauto.

+Qed.

+

+End TRANSL_LABEL.

+

+(** A valid branch in a piece of Mach code translates to a valid ``go to''

+  transition in the generated Asm code. *)

+

+Lemma find_label_goto_label:

+  forall f tf lbl rs m c' b ofs,

+  Genv.find_funct_ptr ge b = Some (Internal f) ->

+  transf_function f = OK tf ->

+  rs PC = Vptr b ofs ->

+  MB.find_label lbl f.(MB.fn_code) = Some c' ->

+  exists tc', exists rs',

+    goto_label tf lbl rs m = Next rs' m

+  /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc'

+  /\ forall r, r <> PC -> rs'#r = rs#r.

+Proof.

+  intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2.

+  intros (tc & A & B).

+  exploit label_pos_code_tail; eauto. instantiate (1 := 0).

+  intros [pos' [P [Q R]]].

+  exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))).

+  split. unfold goto_label. rewrite P. rewrite H1. auto.

+  split. rewrite Pregmap.gss. constructor; auto.

+  rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q.

+  auto. omega.

+  generalize (transf_function_no_overflow _ _ H0). omega.

+  intros. apply Pregmap.gso; auto.

+Qed.

+

+(** Existence of return addresses *)

+

+(* NB: the hypothesis in comment on [b] is not needed in the proof ! 

+*)

+Lemma return_address_exists:

+  forall b f (* sg ros *) c, (* b.(MB.exit) = Some (MBcall sg ros) -> *) is_tail (b :: c) f.(MB.fn_code) ->

+  exists ra, return_address_offset f c ra.

+Proof.

+  intros. eapply Asmblockgenproof0.return_address_exists; eauto.

+

+- intros. monadInv H0.

+  destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. monadInv EQ. simpl.

+(*   rewrite transl_code'_transl_code in EQ0. *)

+  exists x; exists true; split; auto. (*  unfold fn_code. *)

+  repeat constructor.

+  - exact transf_function_no_overflow.

+Qed.

+

+(** * Proof of semantic preservation *)

+

+(** Semantic preservation is proved using simulation diagrams

+  of the following form.

+<<

+           st1 --------------- st2

+            |                   |

+           t|                  *|t

+            |                   |

+            v                   v

+           st1'--------------- st2'

+>>

+  The invariant is the [match_states] predicate below, which includes:

+- The Asm code pointed by the PC register is the translation of

+  the current Mach code sequence.

+- Mach register values and Asm register values agree.

+*)

+

+(*

+Lemma exec_straight_steps:

+  forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2,

+  match_stack ge s ->

+  Mem.extends m2 m2' ->

+  Genv.find_funct_ptr ge fb = Some (Internal f) ->

+  transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc ->

+  (forall k c (TR: transl_instr f i ep k = OK c),

+   exists rs2,

+       exec_straight tge tf c rs1 m1' k rs2 m2'

+    /\ agree ms2 sp rs2

+    /\ (fp_is_parent ep i = true -> rs2#FP = parent_sp s)) ->

+  exists st',

+  plus step tge (State rs1 m1') E0 st' /\

+  match_states (Mach.State s fb sp c ms2 m2) st'.

+Proof.

+  intros. inversion H2. subst. monadInv H7.

+  exploit H3; eauto. intros [rs2 [A [B C]]].

+  exists (State rs2 m2'); split.

+  eapply exec_straight_exec; eauto.

+  econstructor; eauto. eapply exec_straight_at; eauto.

+Qed.

+*)

+

+(*

+Lemma exec_straight_steps_goto:

+  forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c',

+  match_stack ge s ->

+  Mem.extends m2 m2' ->

+  Genv.find_funct_ptr ge fb = Some (Internal f) ->

+  Mach.find_label lbl f.(Mach.fn_code) = Some c' ->

+  transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc ->

+  fp_is_parent ep i = false ->

+  (forall k c (TR: transl_instr f i ep k = OK c),

+   exists jmp, exists k', exists rs2,

+       exec_straight tge tf c rs1 m1' (jmp :: k') rs2 m2'

+    /\ agree ms2 sp rs2

+    /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') ->

+  exists st',

+  plus step tge (State rs1 m1') E0 st' /\

+  match_states (Mach.State s fb sp c' ms2 m2) st'.

+Proof.

+  intros. inversion H3. subst. monadInv H9.

+  exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]].

+  generalize (functions_transl _ _ _ H7 H8); intro FN.

+  generalize (transf_function_no_overflow _ _ H8); intro NOOV.

+  exploit exec_straight_steps_2; eauto.

+  intros [ofs' [PC2 CT2]].

+  exploit find_label_goto_label; eauto.

+  intros [tc' [rs3 [GOTO [AT' OTH]]]].

+  exists (State rs3 m2'); split.

+  eapply plus_right'.

+  eapply exec_straight_steps_1; eauto.

+  econstructor; eauto.

+  eapply find_instr_tail. eauto.

+  rewrite C. eexact GOTO.

+  traceEq.

+  econstructor; eauto.

+  apply agree_exten with rs2; auto with asmgen.

+  congruence.

+Qed.

+

+Lemma exec_straight_opt_steps_goto:

+  forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c',

+  match_stack ge s ->

+  Mem.extends m2 m2' ->

+  Genv.find_funct_ptr ge fb = Some (Internal f) ->

+  Mach.find_label lbl f.(Mach.fn_code) = Some c' ->

+  transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc ->

+  fp_is_parent ep i = false ->

+  (forall k c (TR: transl_instr f i ep k = OK c),

+   exists jmp, exists k', exists rs2,

+       exec_straight_opt tge tf c rs1 m1' (jmp :: k') rs2 m2'

+    /\ agree ms2 sp rs2

+    /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') ->

+  exists st',

+  plus step tge (State rs1 m1') E0 st' /\

+  match_states (Mach.State s fb sp c' ms2 m2) st'.

+Proof.

+  intros. inversion H3. subst. monadInv H9.

+  exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]].

+  generalize (functions_transl _ _ _ H7 H8); intro FN.

+  generalize (transf_function_no_overflow _ _ H8); intro NOOV.

+  inv A.

+- exploit find_label_goto_label; eauto.

+  intros [tc' [rs3 [GOTO [AT' OTH]]]].

+  exists (State rs3 m2'); split.

+  apply plus_one. econstructor; eauto.

+  eapply find_instr_tail. eauto.

+  rewrite C. eexact GOTO.

+  econstructor; eauto.

+  apply agree_exten with rs2; auto with asmgen.

+  congruence.

+- exploit exec_straight_steps_2; eauto.

+  intros [ofs' [PC2 CT2]].

+  exploit find_label_goto_label; eauto.

+  intros [tc' [rs3 [GOTO [AT' OTH]]]].

+  exists (State rs3 m2'); split.

+  eapply plus_right'.

+  eapply exec_straight_steps_1; eauto.

+  econstructor; eauto.

+  eapply find_instr_tail. eauto.

+  rewrite C. eexact GOTO.

+  traceEq.

+  econstructor; eauto.

+  apply agree_exten with rs2; auto with asmgen.

+  congruence.

+Qed. *)

+

+(** We need to show that, in the simulation diagram, we cannot

+  take infinitely many Mach transitions that correspond to zero

+  transitions on the Asm side.  Actually, all Mach transitions

+  correspond to at least one Asm transition, except the

+  transition from [Machsem.Returnstate] to [Machsem.State].

+  So, the following integer measure will suffice to rule out

+  the unwanted behaviour. *)

+

+

+Remark preg_of_not_FP: forall r, negb (mreg_eq r R10) = true -> IR FP <> preg_of r.

+Proof.

+  intros. change (IR FP) with (preg_of R10). red; intros.

+  exploit preg_of_injective; eauto. intros; subst r; discriminate.

+Qed.

+

+Inductive match_states: Machblock.state -> Asmblock.state -> Prop :=

+  | match_states_intro:

+      forall s fb sp c ep ms m m' rs f tf tc

+        (STACKS: match_stack ge s)

+        (FIND: Genv.find_funct_ptr ge fb = Some (Internal f))

+        (MEXT: Mem.extends m m')

+        (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc)

+        (AG: agree ms sp rs)

+        (DXP: ep = true -> rs#FP = parent_sp s),

+      match_states (Machblock.State s fb sp c ms m)

+                   (Asmblock.State rs m')

+  | match_states_call:

+      forall s fb ms m m' rs

+        (STACKS: match_stack ge s)

+        (MEXT: Mem.extends m m')

+        (AG: agree ms (parent_sp s) rs)

+        (ATPC: rs PC = Vptr fb Ptrofs.zero)

+        (ATLR: rs RA = parent_ra s),

+      match_states (Machblock.Callstate s fb ms m)

+                   (Asmblock.State rs m')

+  | match_states_return:

+      forall s ms m m' rs

+        (STACKS: match_stack ge s)

+        (MEXT: Mem.extends m m')

+        (AG: agree ms (parent_sp s) rs)

+        (ATPC: rs PC = parent_ra s),

+      match_states (Machblock.Returnstate s ms m)

+                   (Asmblock.State rs m').

+

+Record codestate :=

+  Codestate {     pstate: state;

+                  pheader: list label;

+                  pbody1: list basic;

+                  pbody2: list basic;

+                  pctl: option control;

+                  fpok: bool;

+                  rem: list AB.bblock;

+                  cur: option bblock }.

+

+(*   | Codestate: state -> list AB.bblock -> option bblock -> codestate. *)

+

+Inductive match_codestate fb: Machblock.state -> codestate -> Prop :=

+  | match_codestate_intro:

+      forall s sp ms m rs0 m0 f tc ep c bb tbb tbc tbi

+        (STACKS: match_stack ge s)

+        (FIND: Genv.find_funct_ptr ge fb = Some (Internal f))

+        (MEXT: Mem.extends m m0)

+        (TBC: transl_basic_code f (MB.body bb) (if MB.header bb then ep else false) = OK tbc)

+        (TIC: transl_instr_control f (MB.exit bb) = OK tbi)

+        (TBLS: transl_blocks f c false = OK tc)

+(*         (TRANS: transl_blocks f (bb::c) ep = OK (tbb::tc)) *)

+        (AG: agree ms sp rs0)

+        (DXP: (if MB.header bb then ep else false) = true -> rs0#FP = parent_sp s)

+        ,

+      match_codestate fb (Machblock.State s fb sp (bb::c) ms m)

+        {|  pstate := (Asmblock.State rs0 m0);

+            pheader := (MB.header bb);

+            pbody1 := tbc;

+            pbody2 := (extract_basic tbi);

+            pctl := extract_ctl tbi;

+            fpok := ep;

+            rem := tc;

+            cur := Some tbb

+        |}

+.

+

+Inductive match_asmstate fb: codestate -> Asmblock.state -> Prop :=

+  | match_asmstate_some:

+      forall rs f tf tc m tbb ofs ep tbdy tex lhd

+        (FIND: Genv.find_funct_ptr ge fb = Some (Internal f))

+        (TRANSF: transf_function f = OK tf)

+        (PCeq: rs PC = Vptr fb ofs)

+        (TAIL: code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (tbb::tc))

+(*         (HDROK: header tbb = lhd) *)

+        ,

+      match_asmstate fb 

+        {|  pstate := (Asmblock.State rs m);

+            pheader := lhd;

+            pbody1 := tbdy;

+            pbody2 := extract_basic tex;

+            pctl := extract_ctl tex;

+            fpok := ep;

+            rem := tc;

+            cur := Some tbb |}

+        (Asmblock.State rs m)

+.

+

+Ltac exploreInst :=

+  repeat match goal with

+  | [ H : match ?var with | _ => _ end = _ |- _ ] => destruct var

+  | [ H : OK _ = OK _ |- _ ] => monadInv H

+  | [ |- context[if ?b then _ else _] ] => destruct b

+  | [ |- context[match ?m with | _ => _ end] ] => destruct m

+  | [ |- context[match ?m as _ return _ with | _ => _ end]] => destruct m

+  | [ H : bind _ _ = OK _ |- _ ] => monadInv H

+  | [ H : Error _ = OK _ |- _ ] => inversion H

+  end.

+

+Lemma transl_blocks_nonil:

+  forall f bb c tc ep,

+  transl_blocks f (bb::c) ep = OK tc ->

+  exists tbb tc', tc = tbb :: tc'.

+Proof.

+  intros until ep. intros TLBS. monadInv TLBS. monadInv EQ. unfold gen_bblocks.

+  destruct (extract_ctl x2).

+  - destruct c0; destruct i; simpl; eauto. destruct x1; simpl; eauto.

+  - destruct x1; simpl; eauto.

+Qed.

+

+Lemma no_builtin_preserved:

+  forall f ex x2,

+  (forall ef args res, ex <> Some (MBbuiltin ef args res)) ->

+  transl_instr_control f ex = OK x2 ->

+  (exists i, extract_ctl x2 = Some (PCtlFlow i))

+    \/ extract_ctl x2 = None.

+Proof.

+  intros until x2. intros Hbuiltin TIC.

+  destruct ex.

+  - destruct c.

+    + simpl in TIC. exploreInst; simpl; eauto.

+    + simpl in TIC. exploreInst; simpl; eauto.

+    + assert (H: Some (MBbuiltin e l b) <>  Some (MBbuiltin e l b)).

+        apply Hbuiltin. contradict H; auto.

+    + simpl in TIC. exploreInst; simpl; eauto.

+    + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; simpl; eauto.

+      * unfold transl_opt_compuimm. exploreInst; simpl; eauto.

+      * unfold transl_opt_compluimm. exploreInst; simpl; eauto.

+    + simpl in TIC. inv TIC.

+    + simpl in TIC. monadInv TIC. simpl. eauto.

+  - monadInv TIC. simpl; auto.

+Qed.

+

+Lemma transl_blocks_distrib:

+  forall c f bb tbb tc ep,

+  transl_blocks f (bb::c) ep = OK (tbb::tc)

+  -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res))

+  -> transl_block f bb (if MB.header bb then ep else false) = OK (tbb :: nil)

+  /\ transl_blocks f c false = OK tc.

+Proof.

+  intros until ep. intros TLBS Hbuiltin.

+  destruct bb as [hd bdy ex].

+  monadInv TLBS. monadInv EQ.

+  exploit no_builtin_preserved; eauto. intros Hectl. destruct Hectl.

+  - destruct H as [i Hectl].

+  unfold gen_bblocks in H0. rewrite Hectl in H0. inv H0.

+  simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl.

+  unfold gen_bblocks. rewrite Hectl. auto.

+  - unfold gen_bblocks in H0. rewrite H in H0.

+    destruct x1 as [|bi x1].

+    + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl.

+      unfold gen_bblocks. rewrite H. auto.

+    + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl.

+      unfold gen_bblocks. rewrite H. auto.

+Qed.

+

+Lemma gen_bblocks_nobuiltin:

+  forall thd tbdy tex tbb,

+  (tbdy <> nil \/ extract_ctl tex <> None) ->

+  (forall ef args res, extract_ctl tex <> Some (PExpand (Pbuiltin ef args res))) ->

+  gen_bblocks thd tbdy tex = tbb :: nil ->

+     header tbb = thd

+  /\ body tbb = tbdy ++ extract_basic tex

+  /\ exit tbb = extract_ctl tex.

+Proof.

+  intros until tbb. intros Hnonil Hnobuiltin GENB. unfold gen_bblocks in GENB.

+  destruct (extract_ctl tex) eqn:ECTL.

+  - destruct c.

+    + destruct i. assert False. eapply Hnobuiltin. eauto. destruct H.

+    + inv GENB. simpl. auto.

+  - inversion Hnonil.

+    + destruct tbdy as [|bi tbdy]; try (contradict H; simpl; auto; fail). inv GENB. auto.

+    + contradict H; simpl; auto.

+Qed.

+

+Lemma transl_instr_basic_nonil:

+  forall k f bi ep x,

+  transl_instr_basic f bi ep k = OK x ->

+  x <> nil.

+Proof.

+  intros until x. intros TIB.

+  destruct bi.

+  - simpl in TIB. unfold loadind in TIB. exploreInst; try discriminate.

+  - simpl in TIB. unfold storeind in TIB. exploreInst; try discriminate.

+  - simpl in TIB. monadInv TIB. unfold loadind in EQ. exploreInst; try discriminate.

+  - simpl in TIB. unfold transl_op in TIB. exploreInst; try discriminate.

+    unfold transl_cond_op in EQ0. exploreInst; try discriminate.

+  - simpl in TIB. unfold transl_load in TIB. exploreInst; try discriminate.

+    all: unfold transl_memory_access in EQ0; exploreInst; try discriminate.

+  - simpl in TIB. unfold transl_store in TIB. exploreInst; try discriminate.

+    all: unfold transl_memory_access in EQ0; exploreInst; try discriminate.

+Qed.

+

+Lemma transl_basic_code_nonil:

+  forall bdy f x ep,

+  bdy <> nil ->

+  transl_basic_code f bdy ep = OK x ->

+  x <> nil.

+Proof.

+  induction bdy as [|bi bdy].

+    intros. contradict H0; auto.

+  destruct bdy as [|bi2 bdy].

+  - clear IHbdy. intros f x b _ TBC. simpl in TBC. eapply transl_instr_basic_nonil; eauto.

+  - intros f x b Hnonil TBC. remember (bi2 :: bdy) as bdy'.

+    monadInv TBC. 

+    assert (x0 <> nil).

+      eapply IHbdy; eauto. subst bdy'. discriminate.

+    eapply transl_instr_basic_nonil; eauto.

+Qed.

+

+Lemma transl_instr_control_nonil:

+  forall ex f x,

+  ex <> None ->

+  transl_instr_control f ex = OK x ->

+  extract_ctl x <> None.

+Proof.

+  intros ex f x Hnonil TIC.

+  destruct ex as [ex|].

+  - clear Hnonil. destruct ex.

+    all: try (simpl in TIC; exploreInst; discriminate).

+    + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; try discriminate.

+      * unfold transl_opt_compuimm. exploreInst; try discriminate.

+      * unfold transl_opt_compluimm. exploreInst; try discriminate.

+  - contradict Hnonil; auto.

+Qed.

+

+Lemma transl_instr_control_nobuiltin:

+  forall f ex x,

+  (forall ef args res, ex <> Some (MBbuiltin ef args res)) ->

+  transl_instr_control f ex = OK x ->

+  (forall ef args res, extract_ctl x <> Some (PExpand (Pbuiltin ef args res))).

+Proof.

+  intros until x. intros Hnobuiltin TIC. intros until res.

+  unfold transl_instr_control in TIC. exploreInst.

+  all: try discriminate.

+  - assert False. eapply Hnobuiltin; eauto. destruct H.

+  - unfold transl_cbranch in TIC. exploreInst.

+    all: try discriminate.

+    + unfold transl_opt_compuimm. exploreInst. all: try discriminate.

+    + unfold transl_opt_compluimm. exploreInst. all: try discriminate.

+Qed.

+

+Theorem match_state_codestate:

+  forall mbs abs s fb sp bb c ms m,

+  (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) ->

+  (MB.body bb <> nil \/ MB.exit bb <> None) ->

+  mbs = (Machblock.State s fb sp (bb::c) ms m) ->

+  match_states mbs abs ->

+  exists cs fb f tbb tc ep,

+    match_codestate fb mbs cs /\ match_asmstate fb cs abs

+    /\ Genv.find_funct_ptr ge fb = Some (Internal f)

+    /\ transl_blocks f (bb::c) ep = OK (tbb::tc)

+    /\ body tbb = pbody1 cs ++ pbody2 cs

+    /\ exit tbb = pctl cs

+    /\ cur cs = Some tbb /\ rem cs = tc

+    /\ pstate cs = abs.

+Proof.

+  intros until m. intros Hnobuiltin Hnotempty Hmbs MS. subst. inv MS.

+  inv AT. clear H0. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst.

+  exploit transl_blocks_distrib; eauto. intros (TLB & TLBS). clear H2.

+  monadInv TLB. exploit gen_bblocks_nobuiltin; eauto.

+    { inversion Hnotempty.

+      - destruct (MB.body bb) as [|bi bdy]; try (contradict H0; simpl; auto; fail).

+        left. eapply transl_basic_code_nonil; eauto.

+      - destruct (MB.exit bb) as [ei|]; try (contradict H0; simpl; auto; fail).

+        right. eapply transl_instr_control_nonil; eauto. }

+    eapply transl_instr_control_nobuiltin; eauto.

+  intros (Hth & Htbdy & Htexit).

+  exists {| pstate := (State rs m'); pheader := (Machblock.header bb); pbody1 := x; pbody2 := extract_basic x0;

+            pctl := extract_ctl x0; fpok := ep; rem := tc'; cur := Some tbb |}, fb, f, tbb, tc', ep.

+  repeat split. 1-2: econstructor; eauto.

+  { destruct (MB.header bb). eauto. discriminate. } eauto.

+  unfold transl_blocks. fold transl_blocks. unfold transl_block. rewrite EQ. simpl. rewrite EQ1; simpl.

+  rewrite TLBS. simpl. rewrite H2.

+  all: simpl; auto.

+Qed.

+

+Definition mb_remove_body (bb: MB.bblock) := 

+  {| MB.header := MB.header bb; MB.body := nil; MB.exit := MB.exit bb |}.

+

+Lemma exec_straight_pnil:

+  forall c rs1 m1 rs2 m2,

+  exec_straight tge c rs1 m1 (Pnop::gnil) rs2 m2 ->

+  exec_straight tge c rs1 m1 nil rs2 m2.

+Proof.

+  intros. eapply exec_straight_trans. eapply H. econstructor; eauto.

+Qed.

+

+Lemma transl_block_nobuiltin:

+  forall f bb ep tbb,

+  (MB.body bb <> nil \/ MB.exit bb <> None) ->

+  (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) ->

+  transl_block f bb ep = OK (tbb :: nil) ->

+  exists c c',

+     transl_basic_code f (MB.body bb) ep = OK c

+  /\ transl_instr_control f (MB.exit bb) = OK c'

+  /\ body tbb = c ++ extract_basic c'

+  /\ exit tbb = extract_ctl c'.

+Proof.

+  intros until tbb. intros Hnonil Hnobuiltin TLB. monadInv TLB. destruct Hnonil.

+  - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto.

+    left. eapply transl_basic_code_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto.

+  - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto.

+    right. eapply transl_instr_control_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto.

+Qed.

+

+Lemma nextblock_preserves: 

+  forall rs rs' bb r,

+  rs' = nextblock bb rs ->

+  data_preg r = true ->

+  rs r = rs' r.

+Proof.

+  intros. destruct r; try discriminate.

+  - subst. Simpl.

+  - subst. Simpl.

+Qed.

+

+Lemma cons3_app {A: Type}:

+  forall a b c (l: list A),

+  a :: b :: c :: l = (a :: b :: c :: nil) ++ l.

+Proof.

+  intros. simpl. auto.

+Qed.

+

+Lemma exec_straight_opt_body2:

+  forall c rs1 m1 c' rs2 m2,

+  exec_straight_opt tge c rs1 m1 c' rs2 m2 ->

+  exists body,

+     exec_body tge body rs1 m1 = Next rs2 m2

+  /\ (basics_to_code body) ++g c' = c.

+Proof.

+  intros until m2. intros EXES.

+  inv EXES.

+  - exists nil. split; auto.

+  - eapply exec_straight_body2. auto.

+Qed.

+

+Lemma extract_basics_to_code:

+  forall lb c,

+  extract_basic (basics_to_code lb ++ c) = lb ++ extract_basic c.

+Proof.

+  induction lb; intros; simpl; congruence.

+Qed.

+

+Lemma extract_ctl_basics_to_code:

+  forall lb c,

+  extract_ctl (basics_to_code lb ++ c) = extract_ctl c.

+Proof.

+  induction lb; intros; simpl; congruence.

+Qed.

+

+(* Lemma goto_label_inv:

+  forall fn tbb l rs m b ofs,

+  rs PC = Vptr b ofs ->

+  goto_label fn l rs m = goto_label fn l (nextblock tbb rs) m.

+Proof.

+  intros.

+  unfold goto_label. rewrite nextblock_pc. unfold Val.offset_ptr. rewrite H.

+  exploreInst; auto.

+  unfold nextblock. rewrite Pregmap.gss.

+  

+Qed.

+

+

+Lemma exec_control_goto_label_inv:

+  exec_control tge fn (Some ctl) rs m = goto_label fn l rs m ->

+  exec_control tge fn (Some ctl) (nextblock tbb rs) m = goto_label fn l (nextblock tbb rs) m.

+Proof.

+Qed. *)

+

+Theorem step_simu_control:

+  forall bb' fb fn s sp c ms' m' rs2 m2 E0 S'' rs1 m1 tbb tbdy2 tex cs2,

+  MB.body bb' = nil ->

+  (forall ef args res, MB.exit bb' <> Some (MBbuiltin ef args res)) ->

+  Genv.find_funct_ptr tge fb = Some (Internal fn) ->

+  pstate cs2 = (Asmblock.State rs2 m2) ->

+  pbody1 cs2 = nil -> pbody2 cs2 = tbdy2 -> pctl cs2 = tex ->

+  cur cs2 = Some tbb ->

+  match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 ->

+  match_asmstate fb cs2 (Asmblock.State rs1 m1) ->

+  exit_step return_address_offset ge (MB.exit bb') (MB.State s fb sp (bb'::c) ms' m') E0 S'' ->

+  (exists rs3 m3 rs4 m4,

+      exec_body tge tbdy2 rs2 m2 = Next rs3 m3

+  /\  exec_control_rel tge fn tex tbb rs3 m3 rs4 m4

+  /\  match_states S'' (State rs4 m4)).

+Proof.

+  intros until cs2. intros Hbody Hbuiltin FIND Hpstate Hpbody1 Hpbody2 Hpctl Hcur MCS MAS ESTEP.

+  inv ESTEP.

+  - inv MCS. inv MAS. simpl in *.

+    inv Hcur. inv Hpstate.

+    destruct ctl.

+    + (* MBcall *)

+      destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.

+      inv TBC. inv TIC. inv H0.

+

+      assert (f0 = f) by congruence. subst f0.

+      assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned).

+        eapply transf_function_no_overflow; eauto.

+      destruct s1 as [rf|fid]; simpl in H7.

+      * (* Indirect call *) inv H1.

+      * (* Direct call *)

+        monadInv H1.

+        generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1.

+        remember (Ptrofs.add _ _) as ofs'.

+        assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc).

+          econstructor; eauto.

+        assert (f1 = f) by congruence. subst f1.

+        exploit return_address_offset_correct; eauto. intros; subst ra.

+        repeat eexists.

+          rewrite H6. econstructor; eauto.

+          rewrite H7. econstructor; eauto.

+        econstructor; eauto.

+          econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl.

+        Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. simpl in H14. rewrite H14. auto.

+        Simpl. simpl. subst. Simpl. simpl. unfold Val.offset_ptr. rewrite PCeq. auto.

+    + (* MBtailcall *)

+      destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.

+      inv TBC. inv TIC. inv H0.

+

+      assert (f0 = f) by congruence.  subst f0.

+      assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned).

+        eapply transf_function_no_overflow; eauto.

+      exploit Mem.loadv_extends. eauto. eexact H15. auto. simpl. intros [parent' [A B]].

+      destruct s1 as [rf|fid]; simpl in H13. 

+      * inv H1.

+      * monadInv H1. assert (f = f1) by congruence. subst f1. clear FIND1. clear H14.

+        exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z).

+        exploit exec_straight_body; eauto.

+          simpl. eauto.

+        intros EXEB.

+        repeat eexists.

+          rewrite H6. simpl extract_basic. eauto.

+          rewrite H7. simpl extract_ctl. simpl. reflexivity.

+        econstructor; eauto.

+        { apply agree_set_other.

+          - econstructor; auto with asmgen.

+            + apply V.

+            + intro r. destruct r; apply V; auto.

+          - eauto with asmgen. }

+        { Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H13. auto. }

+    + (* MBbuiltin (contradiction) *)

+      assert (MB.exit bb' <> Some (MBbuiltin e l b)) by (apply Hbuiltin).

+      rewrite <- H in H1. contradict H1; auto.

+    + (* MBgoto *)

+      destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.

+      inv TBC. inv TIC. inv H0.

+

+      assert (f0 = f) by congruence. subst f0. assert (f1 = f) by congruence. subst f1. clear H11.

+      remember (nextblock tbb rs2) as rs2'.

+      (* inv AT. monadInv H4. *)

+      exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND'.

+      assert (tf = fn) by congruence. subst tf.

+      exploit find_label_goto_label.

+        eauto. eauto.

+        instantiate (2 := rs2').

+        { subst. unfold nextblock. Simpl. unfold Val.offset_ptr. rewrite PCeq. eauto. }

+        eauto.

+      intros (tc' & rs' & GOTO & AT2 & INV).

+

+      eexists. eexists. repeat eexists. repeat split.

+        rewrite H6. simpl extract_basic. simpl. eauto.

+        rewrite H7. simpl extract_ctl. simpl. rewrite <- Heqrs2'. eauto.

+      econstructor; eauto.

+        rewrite Heqrs2' in INV. unfold nextblock in INV.

+        eapply agree_exten; eauto with asmgen.

+        assert (forall r : preg, r <> PC -> rs' r = rs2 r).

+        { intros. destruct r.

+          - destruct g. all: rewrite INV; Simpl; auto.

+          - destruct g. all: rewrite INV; Simpl; auto.

+          - rewrite INV; Simpl; auto.

+          - contradiction. }

+        eauto with asmgen.

+        congruence.

+    + (* MBcond *)

+      destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.

+      inv TBC. inv TIC. inv H0.

+

+      * (* MBcond true *)

+        assert (f0 = f) by congruence. subst f0.

+        exploit eval_condition_lessdef.

+          eapply preg_vals; eauto.

+          all: eauto.

+        intros EC.

+        exploit transl_cbranch_correct_true; eauto. intros (rs' & jmp & A & B & C).

+        exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC).

+        assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. }

+        rewrite PCeq' in PCeq.

+        assert (f1 = f) by congruence. subst f1.

+        exploit find_label_goto_label.

+          4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs')). rewrite nextblock_pc.

+          unfold Val.offset_ptr. rewrite PCeq. eauto.

+        intros (tc' & rs3 & GOTOL & TLPC & Hrs3).

+        exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'.

+        assert (tf = fn) by congruence. subst tf.

+

+        repeat eexists.

+          rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto.

+          rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto.

+

+        econstructor; eauto.

+          eapply agree_exten with rs2; eauto with asmgen.

+          { intros. destruct r; try destruct g; try discriminate.

+            all: rewrite Hrs3; try discriminate; unfold nextblock; Simpl. }

+        intros. discriminate.

+

+      * (* MBcond false *)

+        assert (f0 = f) by congruence. subst f0.

+        exploit eval_condition_lessdef.

+          eapply preg_vals; eauto.

+          all: eauto.

+        intros EC.

+

+        exploit transl_cbranch_correct_false; eauto. intros (rs' & jmp & A & B & C).

+        exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC).

+        assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. }

+        rewrite PCeq' in PCeq.

+        exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'.

+        assert (tf = fn) by congruence. subst tf.

+

+        assert (NOOV: size_blocks fn.(fn_blocks) <= Ptrofs.max_unsigned).

+          eapply transf_function_no_overflow; eauto.

+        generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1.

+

+        repeat eexists.

+          rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto.

+          rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto.

+

+        econstructor; eauto.

+          unfold nextblock. Simpl. unfold Val.offset_ptr. rewrite PCeq. econstructor; eauto.

+          eapply agree_exten with rs2; eauto with asmgen.

+          { intros. destruct r; try destruct g; try discriminate.

+            all: rewrite <- C; try discriminate; unfold nextblock; Simpl. }

+        intros. discriminate.

+    + (* MBjumptable *)

+      destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.

+      inv TBC. inv TIC.

+    + (* MBreturn *)

+      destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.

+      inv TBC. inv TIC. inv H0.

+

+      assert (f0 = f) by congruence. subst f0.

+      assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned).

+        eapply transf_function_no_overflow; eauto.

+      exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z).

+      exploit exec_straight_body; eauto.

+        simpl. eauto.

+      intros EXEB.

+      assert (f1 = f) by congruence. subst f1.

+      

+      repeat eexists.

+        rewrite H6. simpl extract_basic. eauto.

+        rewrite H7. simpl extract_ctl. simpl. reflexivity.

+      econstructor; eauto.

+        unfold nextblock. repeat apply agree_set_other; auto with asmgen.

+

+  - inv MCS. inv MAS. simpl in *. subst. inv Hpstate. inv Hcur.

+(*     exploit transl_blocks_distrib; eauto. (* rewrite <- H2. discriminate. *)

+    intros (TLB & TLBS).

+ *) destruct bb' as [hd' bdy' ex']; simpl in *. subst.

+(*     unfold transl_block in TLB. simpl in TLB. unfold gen_bblocks in TLB; simpl in TLB. inv TLB. *)

+    monadInv TBC. monadInv TIC. simpl in *. rewrite H5. rewrite H6.

+    simpl. repeat eexists.

+    econstructor. 4: instantiate (3 := false). all:eauto.

+      unfold nextblock. Simpl. unfold Val.offset_ptr. rewrite PCeq.

+      assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned).

+        eapply transf_function_no_overflow; eauto.

+      assert (f = f0) by congruence. subst f0. econstructor; eauto.

+      generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. eauto.

+    eapply agree_exten; eauto. intros. Simpl.

+    discriminate.

+Qed.

+

+Definition mb_remove_first (bb: MB.bblock) := 

+  {| MB.header := MB.header bb; MB.body := tail (MB.body bb); MB.exit := MB.exit bb |}.

+

+Lemma exec_straight_body:

+  forall c c' lc rs1 m1 rs2 m2,

+  exec_straight tge c rs1 m1 c' rs2 m2 ->

+  code_to_basics c = Some lc ->

+  exists l ll,

+     c = l ++ c'

+  /\ code_to_basics l = Some ll

+  /\ exec_body tge ll rs1 m1 = Next rs2 m2.

+Proof.

+  induction c; try (intros; inv H; fail).

+  intros until m2. intros EXES CTB. inv EXES.

+  - exists (i1 ::g nil),(i1::nil). repeat (split; simpl; auto). rewrite H6. auto.

+  - inv CTB. destruct (code_to_basics c); try discriminate. inv H0.

+    eapply IHc in H7; eauto. destruct H7 as (l' & ll & Hc & CTB & EXECB). subst.

+    exists (i ::g l'),(i::ll). repeat (split; simpl; auto).

+      rewrite CTB. auto.

+      rewrite H1. auto.

+Qed.

+

+Lemma basics_to_code_app:

+  forall c l x ll,

+  basics_to_code c = l ++ basics_to_code x ->

+  code_to_basics l = Some ll ->

+  c = ll ++ x.

+Proof.

+  intros. apply (f_equal code_to_basics) in H.

+  erewrite code_to_basics_dist in H; eauto. 2: eapply code_to_basics_id.

+  rewrite code_to_basics_id in H. inv H. auto.

+Qed.

+

+Lemma basics_to_code_app2:

+  forall i c l x ll,

+  (PBasic i) :: basics_to_code c = l ++ basics_to_code x ->

+  code_to_basics l = Some ll ->

+  i :: c = ll ++ x.

+Proof.

+  intros until ll. intros.

+  exploit basics_to_code_app. instantiate (3 := (i::c)). simpl.

+  all: eauto.

+Qed.

+

+Lemma step_simu_basic:

+  forall bb bb' s fb sp c ms m rs1 m1 ms' m' bi cs1 tbdy bdy,

+  MB.header bb = nil -> MB.body bb = bi::(bdy) -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) ->

+  bb' = {| MB.header := nil; MB.body := bdy; MB.exit := MB.exit bb |} ->

+  basic_step ge s fb sp ms m bi ms' m' ->

+  pstate cs1 = (State rs1 m1) -> pbody1 cs1 = tbdy ->

+  match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 ->

+  (exists rs2 m2 l cs2 tbdy',

+       cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := tbdy'; pbody2 := pbody2 cs1;

+                pctl := pctl cs1; fpok := fp_is_parent (fpok cs1) bi; rem := rem cs1; cur := cur cs1 |}

+    /\ tbdy = l ++ tbdy'

+    /\ exec_body tge l rs1 m1 = Next rs2 m2

+    /\ match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2).

+Proof.

+  intros until bdy. intros Hheader Hbody Hnobuiltin (* Hnotempty *) Hbb' BSTEP Hpstate Hpbody1 MCS. inv MCS.

+  simpl in *. inv Hpstate.

+  rewrite Hbody in TBC. monadInv TBC.

+  inv BSTEP.

+  - (* MBgetstack *)

+    simpl in EQ0.

+    unfold Mach.load_stack in H.

+    exploit Mem.loadv_extends; eauto. intros [v' [A B]].

+    rewrite (sp_val _ _ _ AG) in A.

+    exploit loadind_correct; eauto with asmgen.

+    intros (rs2 & EXECS & Hrs'1 & Hrs'2).

+    eapply exec_straight_body in EXECS.

+      2: eapply code_to_basics_id; eauto.

+    destruct EXECS as (l & Hlbi & BTC & CTB & EXECB).

+    exists rs2, m1, Hlbi.

+    eexists. eexists. split. instantiate (1 := x). eauto.

+    repeat (split; auto).

+      eapply basics_to_code_app; eauto.

+    remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.

+(*     assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. }

+    rewrite <- Hheadereq. *) subst.

+

+    eapply match_codestate_intro; eauto. simpl. simpl in EQ. (*  { destruct (MB.header bb); auto. } *)

+    eapply agree_set_mreg; eauto with asmgen.

+    intro Hep. simpl in Hep. inv Hep.

+  - (* MBsetstack *)

+    simpl in EQ0.

+    unfold Mach.store_stack in H.

+    assert (Val.lessdef (ms src) (rs1 (preg_of src))). { eapply preg_val; eauto. }

+    exploit Mem.storev_extends; eauto. intros [m2' [A B]].

+    exploit storeind_correct; eauto with asmgen.

+    rewrite (sp_val _ _ _ AG) in A. eauto. intros [rs' [P Q]].

+

+    eapply exec_straight_body in P.

+      2: eapply code_to_basics_id; eauto.

+    destruct P as (l & ll & TBC & CTB & EXECB).

+    exists rs', m2', ll.

+    eexists. eexists. split. instantiate (1 := x). eauto.

+    repeat (split; auto).

+      eapply basics_to_code_app; eauto.

+    remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.

+(*     assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. }

+    rewrite <- Hheadereq. *) subst.

+    eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto.

+

+    eapply agree_undef_regs; eauto with asmgen.

+    simpl; intros. rewrite Q; auto with asmgen. rewrite Hheader in DXP. auto.

+  - (* MBgetparam *)

+    simpl in EQ0.

+

+    assert (f0 = f) by congruence; subst f0.

+    unfold Mach.load_stack in *.

+    exploit Mem.loadv_extends. eauto. eexact H0. auto.

+    intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A.

+    exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'.

+    exploit Mem.loadv_extends. eauto. eexact H1. auto.

+    intros [v' [C D]].

+

+  (* Opaque loadind. *)

+(*     left; eapply exec_straight_steps; eauto; intros. monadInv TR. *)

+    monadInv EQ0. rewrite Hheader. rewrite Hheader in DXP.

+    destruct ep eqn:EPeq.

+  (* GPR31 contains parent *)

+    + exploit loadind_correct. eexact EQ1.

+      instantiate (2 := rs1). rewrite DXP; eauto. congruence.

+      intros [rs2 [P [Q R]]].

+

+      eapply exec_straight_body in P.

+        2: eapply code_to_basics_id; eauto.

+      destruct P as (l & ll & BTC & CTB & EXECB).

+      exists rs2, m1, ll. eexists.

+      eexists. split. instantiate (1 := x). eauto.

+      repeat (split; auto).

+      { eapply basics_to_code_app; eauto. }

+      remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.

+      assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. }

+      (* rewrite <- Hheadereq.  *)subst.

+      eapply match_codestate_intro; eauto.

+

+      eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen.

+      simpl; intros. rewrite R; auto with asmgen.

+      apply preg_of_not_FP; auto.

+

+  (* GPR11 does not contain parent *)

+    + rewrite chunk_of_Tptr in A. 

+      exploit loadind_ptr_correct. eexact A. congruence. intros [rs2 [P [Q R]]].

+      exploit loadind_correct. eexact EQ1. instantiate (2 := rs2). rewrite Q. eauto. congruence.

+      intros [rs3 [S [T U]]].

+

+      exploit exec_straight_trans.

+        eapply P.

+        eapply S.

+      intros EXES.

+

+      eapply exec_straight_body in EXES.

+        2: simpl. 2: erewrite code_to_basics_id; eauto.

+      destruct EXES as (l & ll & BTC & CTB & EXECB).

+      exists rs3, m1, ll.

+      eexists. eexists. split. instantiate (1 := x). eauto.

+      repeat (split; auto).

+        eapply basics_to_code_app2; eauto.

+      remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.

+      assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. }

+      subst.

+      eapply match_codestate_intro; eauto.

+      eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto.

+      instantiate (1 := rs2#FP <- (rs3#FP)). intros.

+      rewrite Pregmap.gso; auto with asmgen.

+      congruence.

+      intros. unfold Pregmap.set. destruct (PregEq.eq r' FP). congruence. auto with asmgen.

+      simpl; intros. rewrite U; auto with asmgen.

+      apply preg_of_not_FP; auto.

+  - (* MBop *)

+    simpl in EQ0. rewrite Hheader in DXP.

+    

+    assert (eval_operation tge sp op (map ms args) m' = Some v).

+      rewrite <- H. apply eval_operation_preserved. exact symbols_preserved.

+    exploit eval_operation_lessdef.

+      eapply preg_vals; eauto.

+      2: eexact H0.

+      all: eauto.

+    intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A.

+    exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]].

+

+    eapply exec_straight_body in P.

+      2: eapply code_to_basics_id; eauto.

+    destruct P as (l & ll & TBC & CTB & EXECB).

+    exists rs2, m1, ll.

+    eexists. eexists. split. instantiate (1 := x). eauto.

+    repeat (split; auto).

+      eapply basics_to_code_app; eauto.

+    remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.

+(*     assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. }

+    rewrite <- Hheadereq. *) subst.

+    eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto.

+    apply agree_set_undef_mreg with rs1; auto. 

+    apply Val.lessdef_trans with v'; auto.

+    simpl; intros. destruct (andb_prop _ _ H1); clear H1.

+    rewrite R; auto. apply preg_of_not_FP; auto.

+Local Transparent destroyed_by_op.

+    destruct op; simpl; auto; congruence.

+  - (* MBload *)

+    simpl in EQ0. rewrite Hheader in DXP.

+

+    assert (eval_addressing tge sp addr (map ms args) = Some a).

+      rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.

+    exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1.

+    intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A.

+    exploit Mem.loadv_extends; eauto. intros [v' [C D]].

+    exploit transl_load_correct; eauto.

+    intros [rs2 [P [Q R]]].

+

+    eapply exec_straight_body in P.

+      2: eapply code_to_basics_id; eauto.

+    destruct P as (l & ll & TBC & CTB & EXECB).

+    exists rs2, m1, ll.

+    eexists. eexists. split. instantiate (1 := x). eauto.

+    repeat (split; auto).

+      eapply basics_to_code_app; eauto.

+    remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.

+(*     assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. }

+    rewrite <- Hheadereq. *) subst.

+    eapply match_codestate_intro; eauto. simpl. simpl in EQ.

+

+    eapply agree_set_undef_mreg; eauto. intros; auto with asmgen.

+    simpl; congruence.

+

+  - (* MBstore *)

+    simpl in EQ0. rewrite Hheader in DXP.

+

+    assert (eval_addressing tge sp addr (map ms args) = Some a).

+      rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.

+    exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1.

+    intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A.

+    assert (Val.lessdef (ms src) (rs1 (preg_of src))). eapply preg_val; eauto.

+    exploit Mem.storev_extends; eauto. intros [m2' [C D]].

+    exploit transl_store_correct; eauto. intros [rs2 [P Q]].

+

+    eapply exec_straight_body in P.

+      2: eapply code_to_basics_id; eauto.

+    destruct P as (l & ll & TBC & CTB & EXECB).

+    exists rs2, m2', ll.

+    eexists. eexists. split. instantiate (1 := x). eauto.

+    repeat (split; auto).

+      eapply basics_to_code_app; eauto.

+    remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.

+    subst.

+    eapply match_codestate_intro; eauto. simpl. simpl in EQ.

+

+    eapply agree_undef_regs; eauto with asmgen.

+    simpl; congruence.

+Qed.

+

+Lemma exec_body_trans:

+  forall l l' rs0 m0 rs1 m1 rs2 m2,

+  exec_body tge l rs0 m0 = Next rs1 m1 ->

+  exec_body tge l' rs1 m1 = Next rs2 m2 ->

+  exec_body tge (l++l') rs0 m0 = Next rs2 m2.

+Proof.

+  induction l.

+  - simpl. congruence.

+  - intros until m2. intros EXEB1 EXEB2.

+    inv EXEB1. destruct (exec_basic_instr _) eqn:EBI; try discriminate.

+    simpl. rewrite EBI. eapply IHl; eauto.

+Qed.

+

+Definition mb_remove_header bb := {| MB.header := nil; MB.body := MB.body bb; MB.exit := MB.exit bb |}.

+

+Program Definition remove_header tbb := {| header := nil; body := body tbb; exit := exit tbb |}.

+Next Obligation.

+  destruct tbb. simpl. auto.

+Qed.

+

+Inductive exec_header: codestate -> codestate -> Prop :=

+  | exec_header_cons: forall cs1,

+      exec_header cs1 {| pstate := pstate cs1; pheader := nil; pbody1 := pbody1 cs1; pbody2 := pbody2 cs1;

+                          pctl := pctl cs1; fpok := (if pheader cs1 then fpok cs1 else false); rem := rem cs1;

+                          (* cur := match cur cs1 with None => None | Some bcur => Some (remove_header bcur) end *)

+                          cur := cur cs1 |}.

+

+Lemma step_simu_header:

+  forall bb s fb sp c ms m rs1 m1 cs1,

+(*   (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> *)

+  pstate cs1 = (State rs1 m1) ->

+  match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 ->

+  (exists cs1',

+       exec_header cs1 cs1'

+    /\ match_codestate fb (MB.State s fb sp (mb_remove_header bb::c) ms m) cs1').

+Proof.

+  intros until cs1. intros Hpstate MCS.

+  eexists. split; eauto.

+  econstructor; eauto.

+  inv MCS. simpl in *. inv Hpstate.

+  econstructor; eauto.

+Qed.

+

+Lemma step_matchasm_header:

+  forall fb cs1 cs1' s1,

+  match_asmstate fb cs1 s1 ->

+  exec_header cs1 cs1' ->

+  match_asmstate fb cs1' s1.

+Proof.

+  intros until s1. intros MAS EXH.

+  inv MAS. inv EXH.

+  simpl. econstructor; eauto.

+Qed.

+

+Lemma step_simu_body:

+  forall bb s fb sp c ms m rs1 m1 ms' cs1 m',

+  MB.header bb = nil ->

+  (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) ->

+  body_step ge s fb sp (MB.body bb) ms m ms' m' ->

+  pstate cs1 = (State rs1 m1) ->

+  match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 ->

+  (exists rs2 m2 cs2 ep,

+       cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := nil; pbody2 := pbody2 cs1;

+                pctl := pctl cs1; fpok := ep; rem := rem cs1; cur := cur cs1 |}

+    /\ exec_body tge (pbody1 cs1) rs1 m1 = Next rs2 m2

+    /\ match_codestate fb (MB.State s fb sp ({| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |}::c) ms' m') cs2).

+Proof.

+  intros bb. destruct bb as [hd bdy ex]; simpl; auto. induction bdy as [|bi bdy].

+  - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS.

+    inv BSTEP.

+    exists rs1, m1, cs1, (fpok cs1).

+    inv MCS. inv Hpstate. simpl in *. monadInv TBC. repeat (split; simpl; auto).

+    econstructor; eauto.

+  - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. inv BSTEP.

+    rename ms' into ms''. rename m' into m''. rename rs' into ms'. rename m'0 into m'.

+    exploit (step_simu_basic); eauto. simpl. eauto. simpl; auto. simpl; auto.

+    intros (rs2 & m2 & l & cs2 & tbdy' & Hcs2 & Happ & EXEB & MCS').

+    simpl in *.

+    exploit IHbdy. auto. 2: eapply H6. 3: eapply MCS'. all: eauto. subst; eauto. simpl; auto.

+    intros (rs3 & m3 & cs3 & ep & Hcs3 & EXEB' & MCS'').

+    exists rs3, m3, cs3, ep.

+    repeat (split; simpl; auto). subst. simpl in *. auto.

+    rewrite Happ. eapply exec_body_trans; eauto. rewrite Hcs2 in EXEB'; simpl in EXEB'. auto.

+Qed.

+

+(* Lemma exec_body_straight:

+  forall l rs0 m0 rs1 m1,

+  l <> nil ->

+  exec_body tge l rs0 m0 = Next rs1 m1 ->

+  exec_straight tge l rs0 m0 nil rs1 m1.

+Proof.

+  induction l as [|i1 l].

+    intros. contradict H; auto.

+  destruct l as [|i2 l].

+  - intros until m1. intros _ EXEB. simpl in EXEB.

+    destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate.

+    inv EXEB. econstructor; eauto.

+  - intros until m1. intros _ EXEB. simpl in EXEB. simpl in IHl.

+    destruct (exec_basic_instr tge i1 rs0 m0) eqn:EBI; try discriminate.

+    econstructor; eauto. eapply IHl; eauto. discriminate.

+Qed. *)

+

+Lemma exec_body_pc:

+  forall l rs1 m1 rs2 m2,

+  exec_body tge l rs1 m1 = Next rs2 m2 ->

+  rs2 PC = rs1 PC.

+Proof.

+  induction l.

+  - intros. inv H. auto.

+  - intros until m2. intro EXEB.

+    inv EXEB. destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate.

+    eapply IHl in H0. rewrite H0.

+    erewrite exec_basic_instr_pc; eauto.

+Qed.

+

+Lemma exec_body_control:

+  forall b rs1 m1 rs2 m2 rs3 m3 fn,

+  exec_body tge (body b) rs1 m1 = Next rs2 m2 ->

+  exec_control_rel tge fn (exit b) b rs2 m2 rs3 m3 ->

+  exec_bblock_rel tge fn b rs1 m1 rs3 m3.

+Proof.

+  intros until fn. intros EXEB EXECTL.

+  econstructor; eauto. inv EXECTL.

+  unfold exec_bblock. rewrite EXEB. auto.

+Qed.

+

+Definition mbsize (bb: MB.bblock) := (length (MB.body bb) + length_opt (MB.exit bb))%nat.

+

+Lemma mbsize_eqz:

+  forall bb, mbsize bb = 0%nat -> MB.body bb = nil /\ MB.exit bb = None.

+Proof.

+  intros. destruct bb as [hd bdy ex]; simpl in *. unfold mbsize in H.

+  remember (length _) as a. remember (length_opt _) as b.

+  assert (a = 0%nat) by omega. assert (b = 0%nat) by omega. subst. clear H.

+  inv H0. inv H1. destruct bdy; destruct ex; auto.

+  all: try discriminate.

+Qed.

+

+Lemma mbsize_neqz:

+  forall bb, mbsize bb <> 0%nat -> (MB.body bb <> nil \/ MB.exit bb <> None).

+Proof.

+  intros. destruct bb as [hd bdy ex]; simpl in *.

+  destruct bdy; destruct ex; try (right; discriminate); try (left; discriminate).

+  contradict H. unfold mbsize. simpl. auto.

+Qed.

+

+(* Alternative form of step_simulation_bblock, easier to prove *)

+Lemma step_simulation_bblock':

+  forall sf f sp bb bb' bb'' rs m rs' m' s'' c S1,

+  bb' = mb_remove_header bb ->

+  body_step ge sf f sp (Machblock.body bb') rs m rs' m' ->

+  bb'' = mb_remove_body bb' ->

+  (forall ef args res, MB.exit bb'' <> Some (MBbuiltin ef args res)) ->

+  exit_step return_address_offset ge (Machblock.exit bb'') (Machblock.State sf f sp (bb'' :: c) rs' m') E0 s'' ->

+  match_states (Machblock.State sf f sp (bb :: c) rs m) S1 ->

+  exists S2 : state, plus step tge S1 E0 S2 /\ match_states s'' S2.

+Proof.

+  intros until S1. intros Hbb' BSTEP Hbb'' Hbuiltin ESTEP MS.

+  destruct (mbsize bb) eqn:SIZE.

+  - apply mbsize_eqz in SIZE. destruct SIZE as (Hbody & Hexit).

+    destruct bb as [hd bdy ex]; simpl in *; subst.

+    inv MS. inv AT. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc.

+    monadInv H2. simpl in *. inv ESTEP. inv BSTEP.

+    eexists. split. eapply plus_one.

+    exploit functions_translated; eauto. intros (tf0 & FIND' & TRANSF'). monadInv TRANSF'.

+    assert (x = tf) by congruence. subst x.

+    eapply exec_step_internal; eauto. eapply find_bblock_tail; eauto.

+    unfold exec_bblock. simpl. eauto.

+    econstructor. eauto. eauto. eauto.

+    unfold nextblock. Simpl. unfold Val.offset_ptr. rewrite <- H.

+    assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned).

+      eapply transf_function_no_overflow; eauto.

+    econstructor; eauto.

+      generalize (code_tail_next_int _ _ _ _ NOOV H3). intro CT1. eauto.

+    eapply agree_exten; eauto. intros. Simpl.

+    intros. discriminate.

+  - subst. exploit mbsize_neqz. { instantiate (1 := bb). rewrite SIZE. discriminate. }

+    intros Hnotempty.

+

+    (* initial setting *)

+    exploit match_state_codestate.

+      2: eapply Hnotempty.

+      all: eauto.

+    intros (cs1 & fb & f0 & tbb & tc & ep & MCS & MAS & FIND & TLBS & Hbody & Hexit & Hcur & Hrem & Hpstate).

+

+    (* step_simu_header part *)

+    assert (exists rs1 m1, pstate cs1 = State rs1 m1). { inv MAS. simpl. eauto. }

+    destruct H as (rs1 & m1 & Hpstate2). subst.

+    assert (f = fb). { inv MCS. auto. } subst fb.

+    exploit step_simu_header.

+      2: eapply MCS.

+      all: eauto.

+    intros (cs1' & EXEH & MCS2).

+

+    (* step_simu_body part *)

+(*     assert (MB.body bb = MB.body (mb_remove_header bb)). { destruct bb; simpl; auto. }

+    rewrite H in BSTEP. clear H. *)

+    assert (Hpstate': pstate cs1' = pstate cs1). { inv EXEH; auto. }

+    exploit step_simu_body.

+      3: eapply BSTEP.

+      4: eapply MCS2.

+      all: eauto. rewrite Hpstate'. eauto.

+    intros (rs2 & m2 & cs2 & ep' & Hcs2 & EXEB & MCS').

+

+    (* step_simu_control part *)

+    assert (exists tf, Genv.find_funct_ptr tge f = Some (Internal tf)).

+    { exploit functions_translated; eauto. intros (tf & FIND' & TRANSF'). monadInv TRANSF'. eauto. }

+    destruct H as (tf & FIND').

+    assert (exists tex, pbody2 cs1 = extract_basic tex /\ pctl cs1 = extract_ctl tex).

+    { inv MAS. simpl in *. eauto. }

+    destruct H as (tex & Hpbody2 & Hpctl).

+    inv EXEH. simpl in *.

+    subst. exploit step_simu_control.

+      9: eapply MCS'. all: simpl.

+      10: eapply ESTEP.

+      all: simpl; eauto.

+      rewrite Hpbody2. rewrite Hpctl. rewrite Hcur.

+      { inv MAS; simpl in *. inv Hcur. inv Hpstate2. eapply match_asmstate_some; eauto.

+        erewrite exec_body_pc; eauto. }

+    intros (rs3 & m3 & rs4 & m4 & EXEB' & EXECTL' & MS').

+

+    (* bringing the pieces together *)

+    exploit exec_body_trans.

+      eapply EXEB.

+      eauto.

+    intros EXEB2.

+    exploit exec_body_control; eauto.

+    rewrite <- Hpbody2 in EXEB2. rewrite <- Hbody in EXEB2. eauto.

+    rewrite Hexit. rewrite Hpctl. eauto.

+    intros EXECB. inv EXECB.

+    exists (State rs4 m4).

+    split; auto. eapply plus_one. rewrite Hpstate2.

+    assert (exists ofs, rs1 PC = Vptr f ofs).

+    { rewrite Hpstate2 in MAS. inv MAS. simpl in *. eauto. }

+    destruct H0 as (ofs & Hrs1pc).

+    eapply exec_step_internal; eauto.

+

+    (* proving the initial find_bblock *)

+    rewrite Hpstate2 in MAS. inv MAS. simpl in *. 

+    assert (f1 = f0) by congruence. subst f0.

+    rewrite PCeq in Hrs1pc. inv Hrs1pc.

+    exploit functions_translated; eauto. intros (tf1 & FIND'' & TRANS''). rewrite FIND' in FIND''.

+    inv FIND''. monadInv TRANS''. rewrite TRANSF0 in EQ. inv EQ. inv Hcur.

+    eapply find_bblock_tail; eauto.

+Qed.

+

+Lemma step_simulation_bblock:

+  forall sf f sp bb ms m ms' m' S2 c,

+  body_step ge sf f sp (Machblock.body bb) ms m ms' m' ->

+  (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) ->

+  exit_step return_address_offset ge (Machblock.exit bb) (Machblock.State sf f sp (bb :: c) ms' m') E0 S2 ->

+  forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' ->

+  exists S2' : state, plus step tge S1' E0 S2' /\ match_states S2 S2'.

+Proof.

+  intros until c. intros BSTEP Hbuiltin ESTEP S1' MS.

+  eapply step_simulation_bblock'; eauto.

+  all: destruct bb as [hd bdy ex]; simpl in *; eauto.

+  inv ESTEP.

+  - econstructor. inv H; try (econstructor; eauto; fail).

+  - econstructor.

+Qed.

+

+Definition measure (s: MB.state) : nat :=

+  match s with

+  | MB.State _ _ _ _ _ _ => 0%nat

+  | MB.Callstate _ _ _ _ => 0%nat

+  | MB.Returnstate _ _ _ => 1%nat

+  end.

+

+Definition split (c: MB.code) :=

+  match c with

+  | nil => nil

+  | bb::c => {| MB.header := MB.header bb; MB.body := MB.body bb; MB.exit := None |}

+              :: {| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |} :: c

+  end.

+

+Lemma cons_ok_eq3 {A: Type} :

+  forall (x:A) y z x' y' z',

+  x = x' -> y = y' -> z = z' ->

+  OK (x::y::z) = OK (x'::y'::z').

+Proof.

+  intros. subst. auto.

+Qed.

+

+Lemma transl_blocks_split_builtin:

+  forall bb c ep f ef args res,

+  MB.exit bb = Some (MBbuiltin ef args res) -> MB.body bb <> nil ->

+  transl_blocks f (split (bb::c)) ep = transl_blocks f (bb::c) ep.

+Proof.

+  intros until res. intros Hexit Hbody. simpl split.

+  unfold transl_blocks. fold transl_blocks. unfold transl_block.

+  simpl. remember (transl_basic_code _ _ _) as tbc. remember (transl_instr_control _ _) as tbi.

+  remember (transl_blocks _ _ _) as tlbs.

+  destruct tbc; destruct tbi; destruct tlbs.

+  all: try simpl; auto.

+  - simpl. rewrite Hexit in Heqtbi. simpl in Heqtbi. monadInv Heqtbi. simpl.

+    unfold gen_bblocks. simpl. destruct l.

+    + exploit transl_basic_code_nonil; eauto. intro. destruct H.

+    + simpl. rewrite app_nil_r. apply cons_ok_eq3. all: try eapply bblock_equality. all: simpl; auto.

+Qed.

+

+Lemma transl_code_at_pc_split_builtin:

+  forall rs f f0 bb c ep tf tc ef args res,

+  MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) ->

+  transl_code_at_pc ge (rs PC) f f0 (bb :: c) ep tf tc ->

+  transl_code_at_pc ge (rs PC) f f0 (split (bb :: c)) ep tf tc.

+Proof.

+  intros until res. intros Hbody Hexit AT. inv AT.

+  econstructor; eauto. erewrite transl_blocks_split_builtin; eauto.

+Qed.

+

+Theorem match_states_split_builtin:

+  forall sf f sp bb c rs m ef args res S1,

+  MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) ->

+  match_states (Machblock.State sf f sp (bb :: c) rs m) S1 ->

+  match_states (Machblock.State sf f sp (split (bb::c)) rs m) S1.

+Proof.

+  intros until S1. intros Hbody Hexit MS.

+  inv MS.

+  econstructor; eauto.

+  eapply transl_code_at_pc_split_builtin; eauto.

+Qed.

+

+Lemma step_simulation_builtin:

+  forall ef args res bb sf f sp c ms m t S2,

+  MB.body bb = nil -> MB.exit bb = Some (MBbuiltin ef args res) ->

+  exit_step return_address_offset ge (MB.exit bb) (Machblock.State sf f sp (bb :: c) ms m) t S2 ->

+  forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' ->

+  exists S2' : state, plus step tge S1' t S2' /\ match_states S2 S2'.

+Proof.

+  intros until S2. intros Hbody Hexit ESTEP S1' MS.

+  inv MS. inv AT. monadInv H2. monadInv EQ.

+  rewrite Hbody in EQ0. monadInv EQ0.

+  rewrite Hexit in EQ. monadInv EQ.

+  rewrite Hexit in ESTEP. inv ESTEP. inv H4.

+

+  exploit functions_transl; eauto. intro FN.

+  generalize (transf_function_no_overflow _ _ H1); intro NOOV.

+  exploit builtin_args_match; eauto. intros [vargs' [P Q]].

+  exploit external_call_mem_extends; eauto.

+  intros [vres' [m2' [A [B [C D]]]]].

+  econstructor; split. apply plus_one.

+  simpl in H3.

+  eapply exec_step_builtin. eauto. eauto.

+    eapply find_bblock_tail; eauto.

+    simpl. eauto.

+    erewrite <- sp_val by eauto.

+    eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved.

+    eapply external_call_symbols_preserved; eauto. apply senv_preserved.

+    eauto.

+  econstructor; eauto.

+    instantiate (2 := tf); instantiate (1 := x0).

+    unfold nextblock. rewrite Pregmap.gss.

+    rewrite set_res_other. rewrite undef_regs_other_2. rewrite Pregmap.gso by congruence. 

+    rewrite <- H. simpl. econstructor; eauto.

+    eapply code_tail_next_int; eauto.

+    rewrite preg_notin_charact. intros. auto with asmgen.

+    auto with asmgen.

+    apply agree_nextblock. eapply agree_set_res; auto.

+    eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto.

+    apply Pregmap.gso; auto with asmgen.

+    congruence.

+Qed.

+

+Theorem step_simulation:

+  forall S1 t S2, MB.step return_address_offset ge S1 t S2 ->

+  forall S1' (MS: match_states S1 S1'),

+  (exists S2', plus step tge S1' t S2' /\ match_states S2 S2')

+  \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat.

+Proof.

+  induction 1; intros.

+

+- (* bblock *)

+  left. destruct (Machblock.exit bb) eqn:MBE; try destruct c0.

+  all: try(inversion H0; subst; inv H2; eapply step_simulation_bblock; 

+            try (rewrite MBE; try discriminate); eauto).

+  + (* MBbuiltin *)

+    destruct (MB.body bb) eqn:MBB.

+    * inv H. eapply step_simulation_builtin; eauto. rewrite MBE. eauto.

+    * eapply match_states_split_builtin in MS; eauto.

+        2: rewrite MBB; discriminate.

+      simpl split in MS.

+      rewrite <- MBB in H.

+      remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb1.

+      assert (MB.body bb = MB.body bb1). { subst. simpl. auto. }

+      rewrite H1 in H. subst.

+      exploit step_simulation_bblock. eapply H.

+        discriminate.

+        simpl. constructor.

+        eauto.

+      intros (S2' & PLUS1 & MS').

+      rewrite MBE in MS'.

+      assert (exit_step return_address_offset ge (Some (MBbuiltin e l b)) 

+              (MB.State sf f sp ({| MB.header := nil; MB.body := nil; MB.exit := Some (MBbuiltin e l b) |}::c) 

+                rs' m') t s').

+      { inv H0. inv H3. econstructor. econstructor; eauto. }

+      exploit step_simulation_builtin.

+        4: eapply MS'.

+        all: simpl; eauto.

+      intros (S3' & PLUS'' & MS'').

+      exists S3'. split; eauto.

+      eapply plus_trans. eapply PLUS1. eapply PLUS''. eauto.

+  + inversion H0. subst. eapply step_simulation_bblock; try (rewrite MBE; try discriminate); eauto.

+

+- (* internal function *)

+  inv MS.

+  exploit functions_translated; eauto. intros [tf [A B]]. monadInv B.

+  generalize EQ; intros EQ'. monadInv EQ'.

+  destruct (zlt Ptrofs.max_unsigned (size_blocks x0.(fn_blocks))); inversion EQ1. clear EQ1. subst x0.

+  unfold Mach.store_stack in *.

+  exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl.

+  intros [m1' [C D]].

+  exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto.

+  intros [m2' [F G]].

+  simpl chunk_of_type in F.

+  exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto.

+  intros [m3' [P Q]].

+  (* Execution of function prologue *)

+  monadInv EQ0. (* rewrite transl_code'_transl_code in EQ1. *)

+  set (tfbody := Pallocframe (fn_stacksize f) (fn_link_ofs f) ::b

+                 Pget GPR8 RA ::b

+                 storeind_ptr GPR8 SP (fn_retaddr_ofs f) ::b x0) in *.

+  set (tf := {| fn_sig := MB.fn_sig f; fn_blocks := tfbody |}) in *.

+  set (rs2 := nextblock (bblock_single_inst (Pallocframe (fn_stacksize f) (fn_link_ofs f))) 

+                          (rs0#FP <- (parent_sp s) #SP <- sp #GPR31 <- Vundef)).

+  exploit (Pget_correct tge GPR8 RA nil rs2 m2'); auto.

+  intros (rs' & U' & V').

+  exploit (exec_straight_through_singleinst); eauto.

+  intro W'. remember (nextblock _ rs') as rs''.

+  exploit (storeind_ptr_correct tge SP (fn_retaddr_ofs f) GPR8 nil rs'' m2').

+    rewrite chunk_of_Tptr in P.

+    assert (rs' GPR8 = rs0 RA). { apply V'. }

+    assert (rs'' GPR8 = rs' GPR8). { subst. Simpl. }

+    assert (rs' GPR12 = rs2 GPR12). { apply V'; discriminate. }

+    assert (rs'' GPR12 = rs' GPR12). { subst. Simpl. }

+    rewrite H4. rewrite H3. rewrite H6. rewrite H5.

+    (* change (rs' GPR8) with (rs0 RA). *)

+    rewrite ATLR.

+    change (rs2 GPR12) with sp. eexact P.

+    congruence. congruence.

+  intros (rs3 & U & V).

+  exploit (exec_straight_through_singleinst); eauto.

+  intro W.

+  remember (nextblock _ rs3) as rs3'.

+  assert (EXEC_PROLOGUE:

+            exec_straight_blocks tge tf

+              tf.(fn_blocks) rs0 m'

+              x0 rs3' m3').

+  { change (fn_blocks tf) with tfbody; unfold tfbody.

+    apply exec_straight_blocks_step with rs2 m2'.

+    unfold exec_bblock. simpl exec_body. rewrite C. fold sp. simpl exec_control.

+    rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. simpl in F. rewrite F. reflexivity.

+    reflexivity.

+    eapply exec_straight_blocks_trans.

+    - eexact W'.

+    - eexact W. }

+  exploit exec_straight_steps_2; eauto using functions_transl.

+  simpl fn_blocks. simpl fn_blocks in g. unfold tfbody. simpl bblock_single_inst. omega. constructor.

+  intros (ofs' & X & Y).                    

+  left; exists (State rs3' m3'); split.

+  eapply exec_straight_steps_1; eauto.

+  simpl fn_blocks. simpl fn_blocks in g. unfold tfbody. simpl bblock_single_inst. omega.

+  constructor.

+  econstructor; eauto.

+  rewrite X; econstructor; eauto. 

+  apply agree_exten with rs2; eauto with asmgen.

+  unfold rs2. 

+  apply agree_nextblock. apply agree_set_other; auto with asmgen.

+  apply agree_change_sp with (parent_sp s). 

+  apply agree_undef_regs with rs0. auto.

+Local Transparent destroyed_at_function_entry.

+  simpl; intros; Simpl.

+  unfold sp; congruence.

+

+  intros.

+  assert (r <> GPR31). { contradict H3; rewrite H3; unfold data_preg; auto. }

+  rewrite Heqrs3'. Simpl. rewrite V. rewrite Heqrs''. Simpl. inversion V'. rewrite H6. auto.

+  assert (r <> GPR8). { contradict H3; rewrite H3; unfold data_preg; auto. }

+  assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. }

+  (* rewrite H8; auto. *)

+  contradict H3; rewrite H3; unfold data_preg; auto.

+  contradict H3; rewrite H3; unfold data_preg; auto.

+  contradict H3; rewrite H3; unfold data_preg; auto.

+  auto. intros. rewrite Heqrs3'. Simpl. rewrite V by auto with asmgen.

+  assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. }

+  rewrite Heqrs''. Simpl.

+  rewrite H4 by auto with asmgen. reflexivity.

+- (* external function *)

+  inv MS.

+  exploit functions_translated; eauto.

+  intros [tf [A B]]. simpl in B. inv B.

+  exploit extcall_arguments_match; eauto.

+  intros [args' [C D]].

+  exploit external_call_mem_extends; eauto.

+  intros [res' [m2' [P [Q [R S]]]]].

+  left; econstructor; split.

+  apply plus_one. eapply exec_step_external; eauto.

+  eapply external_call_symbols_preserved; eauto. apply senv_preserved.

+  econstructor; eauto.

+  unfold loc_external_result.

+  apply agree_set_other; auto.

+  apply agree_set_pair; auto.

+

+- (* return *) 

+  inv MS.

+  inv STACKS. simpl in *.

+  right. split. omega. split. auto.

+  rewrite <- ATPC in H5.

+  econstructor; eauto. congruence.

+Qed.

+

+Lemma transf_initial_states:

+  forall st1, MB.initial_state prog st1 ->

+  exists st2, AB.initial_state tprog st2 /\ match_states st1 st2.

+Proof.

+  intros. inversion H. unfold ge0 in *.

+  econstructor; split.

+  econstructor.

+  eapply (Genv.init_mem_transf_partial TRANSF); eauto.

+  replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero)

+     with (Vptr fb Ptrofs.zero).

+  econstructor; eauto.

+  constructor.

+  apply Mem.extends_refl.

+  split. auto. simpl. unfold Vnullptr; destruct Archi.ptr64; congruence.

+  intros. rewrite Mach.Regmap.gi. auto.

+  unfold Genv.symbol_address.

+  rewrite (match_program_main TRANSF).

+  rewrite symbols_preserved.

+  unfold ge; rewrite H1. auto.

+Qed.

+

+Lemma transf_final_states:

+  forall st1 st2 r,

+  match_states st1 st2 -> MB.final_state st1 r -> AB.final_state st2 r.

+Proof.

+  intros. inv H0. inv H. constructor. assumption.

+  compute in H1. inv H1.

+  generalize (preg_val _ _ _ R0 AG). rewrite H2. intros LD; inv LD. auto.

+Qed.

+

+Definition return_address_offset : Machblock.function -> Machblock.code -> ptrofs -> Prop := 

+  Asmblockgenproof0.return_address_offset.

+

+Theorem transf_program_correct:

+  forward_simulation (MB.semantics return_address_offset prog) (AB.semantics tprog).

+Proof.

+  eapply forward_simulation_star with (measure := measure).

+  - apply senv_preserved.

+  - eexact transf_initial_states.

+  - eexact transf_final_states.

+  - exact step_simulation.

+Qed.

+

+End PRESERVATION.

diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v
new file mode 100644
index 00000000..e2b72295
--- /dev/null
+++ b/mppa_k1c/Asmblockgenproof0.v
@@ -0,0 +1,1081 @@
+Require Import Coqlib.
+Require Intv.
+Require Import AST.
+Require Import Errors.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Memory.
+Require Import Globalenvs.
+Require Import Events.
+Require Import Smallstep.
+Require Import Locations.
+Require Import Machblock.
+Require Import Asmblock.
+Require Import Asmblockgen.
+
+Module MB:=Machblock.
+Module AB:=Asmblock.
+
+Hint Extern 2 (_ <> _) => congruence: asmgen.
+
+Lemma ireg_of_eq:
+  forall r r', ireg_of r = OK r' -> preg_of r = IR r'.
+Proof.
+  unfold ireg_of; intros. destruct (preg_of r); inv H; auto.
+(*   destruct b. all: try discriminate.
+  inv H1. auto.
+ *)Qed.
+
+(* FIXME - Replaced FR by IR for MPPA *)
+Lemma freg_of_eq:
+  forall r r', freg_of r = OK r' -> preg_of r = IR r'.
+Proof.
+  unfold freg_of; intros. destruct (preg_of r); inv H; auto.
+(*   destruct b. all: try discriminate.
+  inv H1. auto.
+ *)Qed.
+
+
+Lemma preg_of_injective:
+  forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2.
+Proof.
+  destruct r1; destruct r2; simpl; intros; reflexivity || discriminate.
+Qed.
+
+Lemma preg_of_data:
+  forall r, data_preg (preg_of r) = true.
+Proof.
+  intros. destruct r; reflexivity.
+Qed.
+Hint Resolve preg_of_data: asmgen.
+
+Lemma data_diff:
+  forall r r',
+  data_preg r = true -> data_preg r' = false -> r <> r'.
+Proof.
+  congruence.
+Qed.
+Hint Resolve data_diff: asmgen.
+
+Lemma preg_of_not_SP:
+  forall r, preg_of r <> SP.
+Proof.
+  intros. unfold preg_of; destruct r; simpl; congruence.
+Qed.
+
+Lemma preg_of_not_PC:
+  forall r, preg_of r <> PC.
+Proof.
+  intros. apply data_diff; auto with asmgen.
+Qed.
+
+Hint Resolve preg_of_not_SP preg_of_not_PC: asmgen.
+
+Lemma nextblock_pc:
+  forall b rs, (nextblock b rs)#PC = Val.offset_ptr rs#PC (Ptrofs.repr (size b)).
+Proof.
+  intros. apply Pregmap.gss.
+Qed.
+
+Lemma nextblock_inv:
+  forall b r rs, r <> PC -> (nextblock b rs)#r = rs#r.
+Proof.
+  intros. unfold nextblock. apply Pregmap.gso. red; intro; subst. auto.
+Qed.
+
+Lemma nextblock_inv1:
+  forall b r rs, data_preg r = true -> (nextblock b rs)#r = rs#r.
+Proof.
+  intros. apply nextblock_inv. red; intro; subst; discriminate.
+Qed.
+
+Lemma undef_regs_other:
+  forall r rl rs,
+  (forall r', In r' rl -> r <> r') ->
+  undef_regs rl rs r = rs r.
+Proof.
+  induction rl; simpl; intros. auto.
+  rewrite IHrl by auto. rewrite Pregmap.gso; auto.
+Qed.
+
+Fixpoint preg_notin (r: preg) (rl: list mreg) : Prop :=
+  match rl with
+  | nil => True
+  | r1 :: nil => r <> preg_of r1
+  | r1 :: rl => r <> preg_of r1 /\ preg_notin r rl
+  end.
+
+Remark preg_notin_charact:
+  forall r rl,
+  preg_notin r rl <-> (forall mr, In mr rl -> r <> preg_of mr).
+Proof.
+  induction rl; simpl; intros.
+  tauto.
+  destruct rl.
+  simpl. split. intros. intuition congruence. auto.
+  rewrite IHrl. split.
+  intros [A B]. intros. destruct H. congruence. auto.
+  auto.
+Qed.
+
+Lemma undef_regs_other_2:
+  forall r rl rs,
+  preg_notin r rl ->
+  undef_regs (map preg_of rl) rs r = rs r.
+Proof.
+  intros. apply undef_regs_other. intros.
+  exploit list_in_map_inv; eauto. intros [mr [A B]]. subst.
+  rewrite preg_notin_charact in H. auto.
+Qed.
+
+(** * Agreement between Mach registers and processor registers *)
+
+Record agree (ms: Mach.regset) (sp: val) (rs: AB.regset) : Prop := mkagree {
+  agree_sp: rs#SP = sp;
+  agree_sp_def: sp <> Vundef;
+  agree_mregs: forall r: mreg, Val.lessdef (ms r) (rs#(preg_of r))
+}.
+
+Lemma preg_val:
+  forall ms sp rs r, agree ms sp rs -> Val.lessdef (ms r) rs#(preg_of r).
+Proof.
+  intros. destruct H. auto.
+Qed.
+
+Lemma preg_vals:
+  forall ms sp rs, agree ms sp rs ->
+  forall l, Val.lessdef_list (map ms l) (map rs (map preg_of l)).
+Proof.
+  induction l; simpl. constructor. constructor. eapply preg_val; eauto. auto.
+Qed.
+
+Lemma sp_val:
+  forall ms sp rs, agree ms sp rs -> sp = rs#SP.
+Proof.
+  intros. destruct H; auto.
+Qed.
+
+Lemma ireg_val:
+  forall ms sp rs r r',
+  agree ms sp rs ->
+  ireg_of r = OK r' ->
+  Val.lessdef (ms r) rs#r'.
+Proof.
+  intros. rewrite <- (ireg_of_eq _ _ H0). eapply preg_val; eauto.
+Qed.
+
+Lemma freg_val:
+  forall ms sp rs r r',
+  agree ms sp rs ->
+  freg_of r = OK r' ->
+  Val.lessdef (ms r) (rs#r').
+Proof.
+  intros. rewrite <- (freg_of_eq _ _ H0). eapply preg_val; eauto.
+Qed.
+
+Lemma agree_exten:
+  forall ms sp rs rs',
+  agree ms sp rs ->
+  (forall r, data_preg r = true -> rs'#r = rs#r) ->
+  agree ms sp rs'.
+Proof.
+  intros. destruct H. split; auto.
+  rewrite H0; auto. auto.
+  intros. rewrite H0; auto. apply preg_of_data.
+Qed.
+
+(** Preservation of register agreement under various assignments. *)
+
+Lemma agree_set_mreg:
+  forall ms sp rs r v rs',
+  agree ms sp rs ->
+  Val.lessdef v (rs'#(preg_of r)) ->
+  (forall r', data_preg r' = true -> r' <> preg_of r -> rs'#r' = rs#r') ->
+  agree (Mach.Regmap.set r v ms) sp rs'.
+Proof.
+  intros. destruct H. split; auto.
+  rewrite H1; auto. apply not_eq_sym. apply preg_of_not_SP.
+  intros. unfold Mach.Regmap.set. destruct (Mach.RegEq.eq r0 r). congruence.
+  rewrite H1. auto. apply preg_of_data.
+  red; intros; elim n. eapply preg_of_injective; eauto.
+Qed.
+
+Corollary agree_set_mreg_parallel:
+  forall ms sp rs r v v',
+  agree ms sp rs ->
+  Val.lessdef v v' ->
+  agree (Mach.Regmap.set r v ms) sp (Pregmap.set (preg_of r) v' rs).
+Proof.
+  intros. eapply agree_set_mreg; eauto. rewrite Pregmap.gss; auto. intros; apply Pregmap.gso; auto.
+Qed.
+
+Lemma agree_set_other:
+  forall ms sp rs r v,
+  agree ms sp rs ->
+  data_preg r = false ->
+  agree ms sp (rs#r <- v).
+Proof.
+  intros. apply agree_exten with rs. auto.
+  intros. apply Pregmap.gso. congruence.
+Qed.
+
+Lemma agree_nextblock:
+  forall ms sp rs b,
+  agree ms sp rs -> agree ms sp (nextblock b rs).
+Proof.
+  intros. unfold nextblock. apply agree_set_other. auto. auto.
+Qed.
+
+Lemma agree_set_pair:
+  forall sp p v v' ms rs,
+  agree ms sp rs ->
+  Val.lessdef v v' ->
+  agree (Mach.set_pair p v ms) sp (set_pair (map_rpair preg_of p) v' rs).
+Proof.
+  intros. destruct p; simpl.
+- apply agree_set_mreg_parallel; auto.
+- apply agree_set_mreg_parallel. apply agree_set_mreg_parallel; auto.
+  apply Val.hiword_lessdef; auto. apply Val.loword_lessdef; auto.
+Qed.
+
+Lemma agree_undef_nondata_regs:
+  forall ms sp rl rs,
+  agree ms sp rs ->
+  (forall r, In r rl -> data_preg r = false) ->
+  agree ms sp (undef_regs rl rs).
+Proof.
+  induction rl; simpl; intros. auto.
+  apply IHrl. apply agree_exten with rs; auto.
+  intros. apply Pregmap.gso. red; intros; subst.
+  assert (data_preg a = false) by auto. congruence.
+  intros. apply H0; auto.
+Qed.
+
+Lemma agree_undef_regs:
+  forall ms sp rl rs rs',
+  agree ms sp rs ->
+  (forall r', data_preg r' = true -> preg_notin r' rl -> rs'#r' = rs#r') ->
+  agree (Mach.undef_regs rl ms) sp rs'.
+Proof.
+  intros. destruct H. split; auto.
+  rewrite <- agree_sp0. apply H0; auto.
+  rewrite preg_notin_charact. intros. apply not_eq_sym. apply preg_of_not_SP.
+  intros. destruct (In_dec mreg_eq r rl).
+  rewrite Mach.undef_regs_same; auto.
+  rewrite Mach.undef_regs_other; auto. rewrite H0; auto.
+  apply preg_of_data.
+  rewrite preg_notin_charact. intros; red; intros. elim n.
+  exploit preg_of_injective; eauto. congruence.
+Qed.
+
+(* Lemma agree_undef_regs2:
+  forall ms sp rl rs rs',
+  agree (Mach.undef_regs rl ms) sp rs ->
+  (forall r', data_preg r' = true -> preg_notin r' rl -> rs'#r' = rs#r') ->
+  agree (Mach.undef_regs rl ms) sp rs'.
+Proof.
+  intros. destruct H. split; auto.
+  rewrite <- agree_sp0. apply H0; auto.
+  rewrite preg_notin_charact. intros. apply not_eq_sym. apply preg_of_not_SP.
+  intros. destruct (In_dec mreg_eq r rl).
+  rewrite Mach.undef_regs_same; auto.
+  rewrite H0; auto.
+  apply preg_of_data.
+  rewrite preg_notin_charact. intros; red; intros. elim n.
+  exploit preg_of_injective; eauto. congruence.
+Qed.
+ *)
+
+Lemma agree_set_undef_mreg:
+  forall ms sp rs r v rl rs',
+  agree ms sp rs ->
+  Val.lessdef v (rs'#(preg_of r)) ->
+  (forall r', data_preg r' = true -> r' <> preg_of r -> preg_notin r' rl -> rs'#r' = rs#r') ->
+  agree (Mach.Regmap.set r v (Mach.undef_regs rl ms)) sp rs'.
+Proof.
+  intros. apply agree_set_mreg with (rs'#(preg_of r) <- (rs#(preg_of r))); auto.
+  apply agree_undef_regs with rs; auto.
+  intros. unfold Pregmap.set. destruct (PregEq.eq r' (preg_of r)).
+  congruence. auto.
+  intros. rewrite Pregmap.gso; auto.
+Qed.
+
+Lemma agree_change_sp:
+  forall ms sp rs sp',
+  agree ms sp rs -> sp' <> Vundef ->
+  agree ms sp' (rs#SP <- sp').
+Proof.
+  intros. inv H. split; auto.
+  intros. rewrite Pregmap.gso; auto with asmgen.
+Qed.
+
+(** Connection between Mach and Asm calling conventions for external
+    functions. *)
+
+Lemma extcall_arg_match:
+  forall ms sp rs m m' l v,
+  agree ms sp rs ->
+  Mem.extends m m' ->
+  Mach.extcall_arg ms m sp l v ->
+  exists v', AB.extcall_arg rs m' l v' /\ Val.lessdef v v'.
+Proof.
+  intros. inv H1.
+  exists (rs#(preg_of r)); split. constructor. eapply preg_val; eauto.
+  unfold Mach.load_stack in H2.
+  exploit Mem.loadv_extends; eauto. intros [v' [A B]].
+  rewrite (sp_val _ _ _ H) in A.
+  exists v'; split; auto.
+  econstructor. eauto. assumption.
+Qed.
+
+Lemma extcall_arg_pair_match:
+  forall ms sp rs m m' p v,
+  agree ms sp rs ->
+  Mem.extends m m' ->
+  Mach.extcall_arg_pair ms m sp p v ->
+  exists v', AB.extcall_arg_pair rs m' p v' /\ Val.lessdef v v'.
+Proof.
+  intros. inv H1.
+- exploit extcall_arg_match; eauto. intros (v' & A & B). exists v'; split; auto. constructor; auto.
+- exploit extcall_arg_match. eauto. eauto. eexact H2. intros (v1 & A1 & B1).
+  exploit extcall_arg_match. eauto. eauto. eexact H3. intros (v2 & A2 & B2).
+  exists (Val.longofwords v1 v2); split. constructor; auto. apply Val.longofwords_lessdef; auto.
+Qed.
+
+
+Lemma extcall_args_match:
+  forall ms sp rs m m', agree ms sp rs -> Mem.extends m m' ->
+  forall ll vl,
+  list_forall2 (Mach.extcall_arg_pair ms m sp) ll vl ->
+  exists vl', list_forall2 (AB.extcall_arg_pair rs m') ll vl' /\ Val.lessdef_list vl vl'.
+Proof.
+  induction 3; intros.
+  exists (@nil val); split. constructor. constructor.
+  exploit extcall_arg_pair_match; eauto. intros [v1' [A B]].
+  destruct IHlist_forall2 as [vl' [C D]].
+  exists (v1' :: vl'); split; constructor; auto.
+Qed.
+
+Lemma extcall_arguments_match:
+  forall ms m m' sp rs sg args,
+  agree ms sp rs -> Mem.extends m m' ->
+  Mach.extcall_arguments ms m sp sg args ->
+  exists args', AB.extcall_arguments rs m' sg args' /\ Val.lessdef_list args args'.
+Proof.
+  unfold Mach.extcall_arguments, AB.extcall_arguments; intros.
+  eapply extcall_args_match; eauto.
+Qed.
+
+Remark builtin_arg_match:
+  forall ge (rs: regset) sp m a v,
+  eval_builtin_arg ge (fun r => rs (preg_of r)) sp m a v ->
+  eval_builtin_arg ge rs sp m (map_builtin_arg preg_of a) v.
+Proof.
+  induction 1; simpl; eauto with barg.
+Qed.
+
+Lemma builtin_args_match:
+  forall ge ms sp rs m m', agree ms sp rs -> Mem.extends m m' ->
+  forall al vl, eval_builtin_args ge ms sp m al vl ->
+  exists vl', eval_builtin_args ge rs sp m' (map (map_builtin_arg preg_of) al) vl'
+           /\ Val.lessdef_list vl vl'.
+Proof.
+  induction 3; intros; simpl.
+  exists (@nil val); split; constructor.
+  exploit (@eval_builtin_arg_lessdef _ ge ms (fun r => rs (preg_of r))); eauto.
+  intros; eapply preg_val; eauto.
+  intros (v1' & A & B).
+  destruct IHlist_forall2 as [vl' [C D]].
+  exists (v1' :: vl'); split; constructor; auto. apply builtin_arg_match; auto.
+Qed.
+
+Lemma agree_set_res:
+  forall res ms sp rs v v',
+  agree ms sp rs ->
+  Val.lessdef v v' ->
+  agree (Mach.set_res res v ms) sp (AB.set_res (map_builtin_res preg_of res) v' rs).
+Proof.
+  induction res; simpl; intros.
+- eapply agree_set_mreg; eauto. rewrite Pregmap.gss. auto.
+  intros. apply Pregmap.gso; auto.
+- auto.
+- apply IHres2. apply IHres1. auto.
+  apply Val.hiword_lessdef; auto.
+  apply Val.loword_lessdef; auto.
+Qed.
+
+Lemma set_res_other:
+  forall r res v rs,
+  data_preg r = false ->
+  set_res (map_builtin_res preg_of res) v rs r = rs r.
+Proof.
+  induction res; simpl; intros.
+- apply Pregmap.gso. red; intros; subst r. rewrite preg_of_data in H; discriminate.
+- auto.
+- rewrite IHres2, IHres1; auto.
+Qed.
+
+(* inspired from Mach *)
+
+Lemma find_label_tail:
+  forall lbl c c', MB.find_label lbl c = Some c' -> is_tail c' c.
+Proof.
+  induction c; simpl; intros. discriminate.
+  destruct (MB.is_label lbl a). inv H. auto with coqlib. eauto with coqlib.
+Qed.
+
+(* inspired from Asmgenproof0 *)
+
+(* ... skip ... *)
+
+(** The ``code tail'' of an instruction list [c] is the list of instructions
+  starting at PC [pos]. *)
+
+Inductive code_tail: Z -> bblocks -> bblocks -> Prop :=
+  | code_tail_0: forall c,
+      code_tail 0 c c
+  | code_tail_S: forall pos bi c1 c2,
+      code_tail pos c1 c2 ->
+      code_tail (pos + (size bi)) (bi :: c1) c2.
+
+Lemma code_tail_pos:
+  forall pos c1 c2, code_tail pos c1 c2 -> pos >= 0.
+Proof.
+  induction 1. omega. generalize (size_positive bi); intros; omega.
+Qed.
+
+Lemma find_bblock_tail:
+  forall c1 bi c2 pos,
+  code_tail pos c1 (bi :: c2) ->
+  find_bblock pos c1 = Some bi.
+Proof.
+  induction c1; simpl; intros.
+  inversion H.  
+  destruct (zlt pos 0). generalize (code_tail_pos _ _ _ H); intro; omega.
+  destruct (zeq pos 0). subst pos.
+  inv H. auto. generalize (size_positive a) (code_tail_pos _ _ _ H4). intro; omega.
+  inv H. congruence. replace (pos0 + size a - size a) with pos0 by omega.
+  eauto.
+Qed.
+
+
+Local Hint Resolve code_tail_0 code_tail_S.
+
+Lemma code_tail_next:
+  forall fn ofs c0,
+  code_tail ofs fn c0 ->
+  forall bi c1, c0 = bi :: c1 -> code_tail (ofs + (size bi)) fn c1.
+Proof.
+  induction 1; intros.
+  - subst; eauto.
+  - replace (pos + size bi + size bi0) with ((pos + size bi0) + size bi); eauto.
+    omega.
+Qed.
+
+Lemma size_blocks_pos c: 0 <= size_blocks c.
+Proof.
+  induction c as [| a l ]; simpl; try omega.
+  generalize (size_positive a); omega.
+Qed.
+
+Remark code_tail_positive:
+  forall fn ofs c,
+  code_tail ofs fn c -> 0 <= ofs.
+Proof.
+  induction 1; intros; simpl.
+  - omega.
+  - generalize (size_positive bi). omega.
+Qed.
+
+Remark code_tail_size:
+  forall fn ofs c,
+  code_tail ofs fn c -> size_blocks fn = ofs + size_blocks c.
+Proof.
+  induction 1; intros; simpl; try omega.
+Qed.
+
+Remark code_tail_bounds fn ofs c:
+  code_tail ofs fn c -> 0 <= ofs <= size_blocks fn.
+Proof.
+  intro H; 
+  exploit code_tail_size; eauto.
+  generalize (code_tail_positive _ _ _ H), (size_blocks_pos c).
+  omega.
+Qed.
+
+Local Hint Resolve code_tail_next.
+
+Lemma code_tail_next_int:
+  forall fn ofs bi c,
+  size_blocks fn <= Ptrofs.max_unsigned ->
+  code_tail (Ptrofs.unsigned ofs) fn (bi :: c) ->
+  code_tail (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr (size bi)))) fn c.
+Proof.
+  intros. 
+  exploit code_tail_size; eauto.
+  simpl; generalize (code_tail_positive _ _ _ H0), (size_positive bi), (size_blocks_pos c).
+  intros.
+  rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_repr.
+  - rewrite Ptrofs.unsigned_repr; eauto.
+    omega.
+  - rewrite Ptrofs.unsigned_repr; omega.
+Qed.
+
+(** Predictor for return addresses in generated Asm code.
+
+  The [return_address_offset] predicate defined here is used in the
+  semantics for Mach to determine the return addresses that are
+  stored in activation records. *)
+
+(** Consider a Mach function [f] and a sequence [c] of Mach instructions
+  representing the Mach code that remains to be executed after a
+  function call returns.  The predicate [return_address_offset f c ofs]
+  holds if [ofs] is the integer offset of the PPC instruction
+  following the call in the Asm code obtained by translating the
+  code of [f]. Graphically:
+<<
+     Mach function f    |--------- Mcall ---------|
+         Mach code c    |                |--------|
+                        |                 \        \
+                        |                  \        \
+                        |                   \        \
+     Asm code           |                    |--------|
+     Asm function       |------------- Pcall ---------|
+
+                        <-------- ofs ------->
+>>
+*)
+
+Definition return_address_offset (f: MB.function) (c: MB.code) (ofs: ptrofs) : Prop :=
+  forall tf  tc,
+  transf_function f = OK tf ->
+  transl_blocks f c false = OK tc ->
+  code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc.
+
+(* NB: these two lemma should go into [Coqlib.v] *) 
+Lemma is_tail_app A (l1: list A): forall l2, is_tail l2 (l1 ++ l2).
+Proof.
+  induction l1; simpl; auto with coqlib.
+Qed.
+Hint Resolve is_tail_app: coqlib.
+
+Lemma is_tail_app_inv A (l1: list A): forall l2 l3, is_tail (l1 ++ l2) l3 -> is_tail l2 l3.
+Proof.
+  induction l1; simpl; auto with coqlib.
+  intros l2 l3 H; inversion H; eauto with coqlib.
+Qed.
+Hint Resolve is_tail_app_inv: coqlib.
+
+
+Lemma transl_blocks_tail:
+  forall f c1 c2, is_tail c1 c2 ->
+  forall tc2 ep2, transl_blocks f c2 ep2 = OK tc2 ->
+  exists tc1, exists ep1, transl_blocks f c1 ep1 = OK tc1 /\ is_tail tc1 tc2.
+Proof.
+  induction 1; simpl; intros.
+  exists tc2; exists ep2; split; auto with coqlib.
+  monadInv H0. exploit IHis_tail; eauto. intros (tc1 & ep1 & A & B).
+  exists tc1; exists ep1; split. auto.
+  eapply is_tail_trans with x0; eauto with coqlib.
+Qed.
+
+Lemma is_tail_code_tail:
+  forall c1 c2, is_tail c1 c2 -> exists ofs, code_tail ofs c2 c1.
+Proof.
+  induction 1; eauto.
+  destruct IHis_tail; eauto. 
+Qed.
+
+Section RETADDR_EXISTS.
+
+Hypothesis transf_function_inv:
+  forall f tf, transf_function f = OK tf ->
+  exists tc ep, transl_blocks f (Machblock.fn_code f) ep = OK tc /\ is_tail tc (fn_blocks tf).
+
+Hypothesis transf_function_len:
+  forall f tf, transf_function f = OK tf -> size_blocks (fn_blocks tf) <= Ptrofs.max_unsigned.
+
+
+(* NB: the hypothesis in comment on [b] is not needed in the proof ! *)
+Lemma return_address_exists:
+  forall b f (* sg ros *) c, (* b.(MB.exit) = Some (MBcall sg ros) -> *) is_tail (b :: c) f.(MB.fn_code) ->
+  exists ra, return_address_offset f c ra.
+Proof.
+  intros. destruct (transf_function f) as [tf|] eqn:TF.
+  + exploit transf_function_inv; eauto. intros (tc1 & ep1 & TR1 & TL1).
+    exploit transl_blocks_tail; eauto. intros (tc2 & ep2 & TR2 & TL2).
+(*     unfold return_address_offset. *)
+    monadInv TR2.
+    assert (TL3: is_tail x0 (fn_blocks tf)).
+    { apply is_tail_trans with tc1; auto. 
+      apply is_tail_trans with (x++x0); auto. eapply is_tail_app.
+    }
+    exploit is_tail_code_tail. eexact TL3. intros [ofs CT].
+    exists (Ptrofs.repr ofs). red; intros.
+    rewrite Ptrofs.unsigned_repr. congruence.
+    exploit code_tail_bounds; eauto.
+    intros; apply transf_function_len in TF. omega.
+  + exists Ptrofs.zero; red; intros. congruence.
+Qed.
+
+End RETADDR_EXISTS.
+
+(** [transl_code_at_pc pc fb f c ep tf tc] holds if the code pointer [pc] points
+  within the Asm code generated by translating Mach function [f],
+  and [tc] is the tail of the generated code at the position corresponding
+  to the code pointer [pc]. *)
+
+Inductive transl_code_at_pc (ge: MB.genv):
+    val -> block -> MB.function -> MB.code -> bool -> AB.function -> AB.bblocks -> Prop :=
+  transl_code_at_pc_intro:
+    forall b ofs f c ep tf tc,
+    Genv.find_funct_ptr ge b = Some(Internal f) ->
+    transf_function f = Errors.OK tf ->
+    transl_blocks f c ep = OK tc ->
+    code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc ->
+    transl_code_at_pc ge (Vptr b ofs) b f c ep tf tc.
+
+Remark code_tail_no_bigger:
+  forall pos c1 c2, code_tail pos c1 c2 -> (length c2 <= length c1)%nat.
+Proof.
+  induction 1; simpl; omega.
+Qed.
+
+Remark code_tail_unique:
+  forall fn c pos pos',
+  code_tail pos fn c -> code_tail pos' fn c -> pos = pos'.
+Proof.
+  induction fn; intros until pos'; intros ITA CT; inv ITA; inv CT; auto.
+  generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega.
+  generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega.
+  f_equal. eauto.
+Qed.
+
+Lemma return_address_offset_correct:
+  forall ge b ofs fb f c tf tc ofs',
+  transl_code_at_pc ge (Vptr b ofs) fb f c false tf tc ->
+  return_address_offset f c ofs' ->
+  ofs' = ofs.
+Proof.
+  intros. inv H. red in H0.
+  exploit code_tail_unique. eexact H12. eapply H0; eauto. intro.
+  rewrite <- (Ptrofs.repr_unsigned ofs).
+  rewrite <- (Ptrofs.repr_unsigned ofs').
+  congruence.
+Qed.
+
+(** The [find_label] function returns the code tail starting at the
+  given label.  A connection with [code_tail] is then established. *)
+
+Fixpoint find_label (lbl: label) (c: bblocks) {struct c} : option bblocks :=
+  match c with
+  | nil => None
+  | bb1 :: bbl => if is_label lbl bb1 then Some c else find_label lbl bbl
+  end.
+
+Lemma label_pos_code_tail:
+  forall lbl c pos c',
+  find_label lbl c = Some c' ->
+  exists pos',
+  label_pos lbl pos c = Some pos'
+  /\ code_tail (pos' - pos) c c'
+  /\ pos <= pos' <= pos + size_blocks c.
+Proof.
+  induction c.
+  simpl; intros. discriminate.
+  simpl; intros until c'.
+  case (is_label lbl a).
+  - intros. inv H. exists pos. split; auto. split.
+    replace (pos - pos) with 0 by omega. constructor. constructor; try omega.
+    generalize (size_blocks_pos c). generalize (size_positive a). omega.
+  - intros. generalize (IHc (pos+size a) c' H). intros [pos' [A [B C]]].
+  exists pos'. split. auto. split.
+  replace (pos' - pos) with ((pos' - (pos + (size a))) + (size a)) by omega.
+  constructor. auto. generalize (size_positive a). omega.
+Qed.
+
+(** Helper lemmas to reason about
+- the "code is tail of" property
+- correct translation of labels. *)
+
+Definition tail_nolabel (k c: bblocks) : Prop :=
+  is_tail k c /\ forall lbl, find_label lbl c = find_label lbl k.
+
+Lemma tail_nolabel_refl:
+  forall c, tail_nolabel c c.
+Proof.
+  intros; split. apply is_tail_refl. auto.
+Qed.
+
+Lemma tail_nolabel_trans:
+  forall c1 c2 c3, tail_nolabel c2 c3 -> tail_nolabel c1 c2 -> tail_nolabel c1 c3.
+Proof.
+  intros. destruct H; destruct H0; split.
+  eapply is_tail_trans; eauto.
+  intros. rewrite H1; auto.
+Qed.
+
+Definition nolabel (b: bblock) :=
+  match (header b) with nil => True | _ => False end.
+
+Hint Extern 1 (nolabel _) => exact I : labels.
+
+Lemma tail_nolabel_cons:
+  forall b c k,
+  nolabel b -> tail_nolabel k c -> tail_nolabel k (b :: c).
+Proof.
+  intros. destruct H0. split.
+  constructor; auto.
+  intros. simpl. rewrite <- H1. destruct b as [hd bdy ex]; simpl in *.
+  destruct hd as [|l hd]; simpl in *.
+  - assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false).
+    { apply is_label_correct_false. simpl header. apply in_nil. }
+    rewrite H2. auto.
+  - contradiction.
+Qed.
+
+Hint Resolve tail_nolabel_refl: labels.
+
+Ltac TailNoLabel :=
+  eauto with labels;
+  match goal with
+  | [ |- tail_nolabel _ (_ :: _) ] => apply tail_nolabel_cons; [auto; exact I | TailNoLabel]
+  | [ H: Error _ = OK _ |- _ ] => discriminate
+  | [ H: assertion_failed = OK _ |- _ ] => discriminate
+  | [ H: OK _ = OK _ |- _ ] => inv H; TailNoLabel
+  | [ H: bind _ _ = OK _ |- _ ] => monadInv H;  TailNoLabel
+  | [ H: (if ?x then _ else _) = OK _ |- _ ] => destruct x; TailNoLabel
+  | [ H: match ?x with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct x; TailNoLabel
+  | _ => idtac
+  end.
+
+Remark tail_nolabel_find_label:
+  forall lbl k c, tail_nolabel k c -> find_label lbl c = find_label lbl k.
+Proof.
+  intros. destruct H. auto.
+Qed.
+
+Remark tail_nolabel_is_tail:
+  forall k c, tail_nolabel k c -> is_tail k c.
+Proof.
+  intros. destruct H. auto.
+Qed.
+
+Section STRAIGHTLINE.
+
+Variable ge: genv.
+Variable fn: function.
+
+(** Straight-line code is composed of processor instructions that execute
+  in sequence (no branches, no function calls and returns).
+  The following inductive predicate relates the machine states
+  before and after executing a straight-line sequence of instructions.
+  Instructions are taken from the first list instead of being fetched
+  from memory. *)
+
+Inductive exec_straight: list instruction -> regset -> mem ->
+                         list instruction -> regset -> mem -> Prop :=
+  | exec_straight_one:
+      forall i1 c rs1 m1 rs2 m2,
+      exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 ->
+      exec_straight ((PBasic i1) ::g c) rs1 m1 c rs2 m2
+  | exec_straight_step:
+      forall i c rs1 m1 rs2 m2 c' rs3 m3,
+      exec_basic_instr ge i rs1 m1 = Next rs2 m2 ->
+      exec_straight c rs2 m2 c' rs3 m3 ->
+      exec_straight ((PBasic i) :: c) rs1 m1 c' rs3 m3.
+
+Inductive exec_control_rel: option control -> bblock -> regset -> mem ->
+                             regset -> mem -> Prop :=
+  | exec_control_rel_intro:
+      forall rs1 m1 b rs1' ctl rs2 m2,
+      rs1' = nextblock b rs1 ->
+      exec_control ge fn ctl rs1' m1 = Next rs2 m2 ->
+      exec_control_rel ctl b rs1 m1 rs2 m2.
+
+Inductive exec_bblock_rel: bblock -> regset -> mem -> regset -> mem -> Prop :=
+  | exec_bblock_rel_intro:
+      forall rs1 m1 b rs2 m2,
+      exec_bblock ge fn b rs1 m1 = Next rs2 m2 ->
+      exec_bblock_rel b rs1 m1 rs2 m2.
+
+Lemma exec_straight_body:
+  forall c l rs1 m1 rs2 m2,
+  exec_straight c rs1 m1 nil rs2 m2 ->
+  code_to_basics c = Some l ->
+  exec_body ge l rs1 m1 = Next rs2 m2.
+Proof.
+  induction c as [|i c].
+  - intros until m2. intros EXES CTB. inv EXES.
+  - intros until m2. intros EXES CTB. inv EXES.
+    + inv CTB. simpl. rewrite H6. auto.
+    + inv CTB. destruct (code_to_basics c); try discriminate. inv H0. eapply IHc in H7; eauto.
+      rewrite <- H7. simpl. rewrite H1. auto.
+Qed.
+
+Lemma exec_straight_body2:
+  forall c rs1 m1 c' rs2 m2,
+  exec_straight c rs1 m1 c' rs2 m2 ->
+  exists body,
+     exec_body ge body rs1 m1 = Next rs2 m2
+  /\ (basics_to_code body) ++g c' = c.
+Proof.
+  intros until m2. induction 1.
+  - exists (i1::nil). split; auto. simpl. rewrite H. auto.
+  - destruct IHexec_straight as (bdy & EXEB & BTC).
+    exists (i:: bdy). split; simpl.
+    + rewrite H. auto.
+    + congruence.
+Qed.
+
+Lemma exec_straight_trans:
+  forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3,
+  exec_straight c1 rs1 m1 c2 rs2 m2 ->
+  exec_straight c2 rs2 m2 c3 rs3 m3 ->
+  exec_straight c1 rs1 m1 c3 rs3 m3.
+Proof.
+  induction 1; intros.
+  apply exec_straight_step with rs2 m2; auto.
+  apply exec_straight_step with rs2 m2; auto.
+Qed.
+
+(* Theorem exec_straight_bblock:
+  forall rs1 m1 rs2 m2 rs3 m3 b,
+  exec_straight (body b) rs1 m1 nil rs2 m2 ->
+  exec_control_rel (exit b) b rs2 m2 rs3 m3 ->
+  exec_bblock_rel b rs1 m1 rs3 m3.
+Proof.
+  intros.
+  econstructor; eauto. unfold exec_bblock. erewrite exec_straight_body; eauto.
+  inv H0. auto.
+Qed. *)
+
+
+Lemma exec_straight_two:
+  forall i1 i2 c rs1 m1 rs2 m2 rs3 m3,
+  exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 ->
+  exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 ->
+  exec_straight (i1 ::g i2 ::g c) rs1 m1 c rs3 m3.
+Proof.
+  intros. apply exec_straight_step with rs2 m2; auto.
+  apply exec_straight_one; auto.
+Qed.
+
+Lemma exec_straight_three:
+  forall i1 i2 i3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4,
+  exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 ->
+  exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 ->
+  exec_basic_instr ge i3 rs3 m3 = Next rs4 m4 ->
+  exec_straight (i1 ::g i2 ::g i3 ::g c) rs1 m1 c rs4 m4.
+Proof.
+  intros. apply exec_straight_step with rs2 m2; auto.
+  eapply exec_straight_two; eauto.
+Qed.
+
+(** Like exec_straight predicate, but on blocks *)
+
+Inductive exec_straight_blocks: bblocks -> regset -> mem ->
+                                bblocks -> regset -> mem -> Prop :=
+  | exec_straight_blocks_one:
+      forall b1 c rs1 m1 rs2 m2,
+      exec_bblock ge fn b1 rs1 m1 = Next rs2 m2 ->
+      rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b1)) ->
+      exec_straight_blocks (b1 :: c) rs1 m1 c rs2 m2
+  | exec_straight_blocks_step:
+      forall b c rs1 m1 rs2 m2 c' rs3 m3,
+      exec_bblock ge fn b rs1 m1 = Next rs2 m2 ->
+      rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b)) ->
+      exec_straight_blocks c rs2 m2 c' rs3 m3 ->
+      exec_straight_blocks (b :: c) rs1 m1 c' rs3 m3.
+
+Lemma exec_straight_blocks_trans:
+  forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3,
+  exec_straight_blocks c1 rs1 m1 c2 rs2 m2 ->
+  exec_straight_blocks c2 rs2 m2 c3 rs3 m3 ->
+  exec_straight_blocks c1 rs1 m1 c3 rs3 m3.
+Proof.
+  induction 1; intros.
+  apply exec_straight_blocks_step with rs2 m2; auto.
+  apply exec_straight_blocks_step with rs2 m2; auto.
+Qed.
+
+(** Linking exec_straight with exec_straight_blocks *)
+
+Ltac Simplif :=
+  ((rewrite nextblock_inv by eauto with asmgen)
+  || (rewrite nextblock_inv1 by eauto with asmgen)
+  || (rewrite Pregmap.gss)
+  || (rewrite nextblock_pc)
+  || (rewrite Pregmap.gso by eauto with asmgen)
+  ); auto with asmgen.
+
+Ltac Simpl := repeat Simplif.
+
+Lemma exec_basic_instr_pc:
+  forall b rs1 m1 rs2 m2,
+  exec_basic_instr ge b rs1 m1 = Next rs2 m2 ->
+  rs2 PC = rs1 PC.
+Proof.
+  intros. destruct b; try destruct i; try destruct i.
+  all: try (inv H; Simpl).
+  all: try (unfold exec_load in H1; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]).
+  all: try (unfold exec_store in H1; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]).
+  destruct (Mem.alloc _ _ _). destruct (Mem.store _ _ _ _ _). inv H1. Simpl. discriminate.
+  destruct (rs1 _); try discriminate.
+  destruct (Mem.free _ _ _ _). inv H0. Simpl. discriminate.
+  destruct rs; try discriminate. inv H1. Simpl.
+  destruct rd; try discriminate. inv H1; Simpl.
+  auto.
+Qed.
+
+(* Lemma exec_straight_pc':
+  forall c rs1 m1 rs2 m2,
+  exec_straight c rs1 m1 nil rs2 m2 ->
+  rs2 PC = rs1 PC.
+Proof.
+  induction c; intros; try (inv H; fail).
+  inv H.
+  - erewrite exec_basic_instr_pc; eauto.
+  - rewrite (IHc rs3 m3 rs2 m2); auto.
+    erewrite exec_basic_instr_pc; eauto.
+Qed. *)
+
+Lemma exec_straight_pc:
+  forall c c' rs1 m1 rs2 m2,
+  exec_straight c rs1 m1 c' rs2 m2 ->
+  rs2 PC = rs1 PC.
+Proof.
+  induction c; intros; try (inv H; fail).
+  inv H.
+  - eapply exec_basic_instr_pc; eauto.
+  - rewrite (IHc c' rs3 m3 rs2 m2); auto.
+    erewrite exec_basic_instr_pc; eauto.
+Qed.
+
+(* Lemma exec_straight_through:
+  forall c i b lb rs1 m1 rs2 m2 rs2' m2',
+  bblock_basic_ctl c i = b ->
+  exec_straight c rs1 m1 nil rs2 m2 ->
+  nextblock b rs2 = rs2' -> m2 = m2' ->
+  exec_control ge fn i rs2' m2' = Next rs2' m2' -> (* if the control does not jump *)
+  exec_straight_blocks (b::lb) rs1 m1 lb rs2' m2'.
+Proof.
+  intros. subst. destruct i.
+  - constructor 1. 
+      + unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto.
+      + rewrite <- (exec_straight_pc c nil rs1 m1 rs2 m2'); auto.
+  - destruct c as [|i c]; try (inv H0; fail).
+    constructor 1.
+    + unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto.
+    + rewrite <- (exec_straight_pc (i ::i c) nil rs1 m1 rs2 m2'); auto.
+Qed.
+ *)
+Lemma exec_straight_through_singleinst:
+  forall a b rs1 m1 rs2 m2 rs2' m2' lb,
+  bblock_single_inst (PBasic a) = b ->
+  exec_straight (a ::g nil) rs1 m1 nil rs2 m2 ->
+  nextblock b rs2 = rs2' -> m2 = m2' ->
+  exec_straight_blocks (b::lb) rs1 m1 lb rs2' m2'.
+Proof.
+  intros. subst. constructor 1. unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto.
+  simpl. auto.
+  simpl; auto. unfold nextblock; simpl. Simpl. erewrite exec_straight_pc; eauto.
+Qed.
+
+(** The following lemmas show that straight-line executions
+  (predicate [exec_straight_blocks]) correspond to correct Asm executions. *)
+
+Lemma exec_straight_steps_1:
+  forall c rs m c' rs' m',
+  exec_straight_blocks c rs m c' rs' m' ->
+  size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned ->
+  forall b ofs,
+  rs#PC = Vptr b ofs ->
+  Genv.find_funct_ptr ge b = Some (Internal fn) ->
+  code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c ->
+  plus step ge (State rs m) E0 (State rs' m').
+Proof.
+  induction 1; intros.
+  apply plus_one.
+  econstructor; eauto.
+  eapply find_bblock_tail. eauto.
+  eapply plus_left'.
+  econstructor; eauto.
+  eapply find_bblock_tail. eauto.
+  apply IHexec_straight_blocks with b0 (Ptrofs.add ofs (Ptrofs.repr (size b))).
+  auto. rewrite H0. rewrite H3. reflexivity.
+  auto.
+  apply code_tail_next_int; auto.
+  traceEq.
+Qed.
+
+Lemma exec_straight_steps_2:
+  forall c rs m c' rs' m',
+  exec_straight_blocks c rs m c' rs' m' ->
+  size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned ->
+  forall b ofs,
+  rs#PC = Vptr b ofs ->
+  Genv.find_funct_ptr ge b = Some (Internal fn) ->
+  code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c ->
+  exists ofs',
+     rs'#PC = Vptr b ofs'
+  /\ code_tail (Ptrofs.unsigned ofs') (fn_blocks fn) c'.
+Proof.
+  induction 1; intros.
+  exists (Ptrofs.add ofs (Ptrofs.repr (size b1))). split.
+  rewrite H0. rewrite H2. auto.
+  apply code_tail_next_int; auto.
+  apply IHexec_straight_blocks with (Ptrofs.add ofs (Ptrofs.repr (size b))).
+  auto. rewrite H0. rewrite H3. reflexivity. auto.
+  apply code_tail_next_int; auto.
+Qed.
+
+End STRAIGHTLINE.
+
+
+(** * Properties of the Machblock call stack *)
+
+Section MATCH_STACK.
+
+Variable ge: MB.genv.
+
+Inductive match_stack: list MB.stackframe -> Prop :=
+  | match_stack_nil:
+      match_stack nil
+  | match_stack_cons: forall fb sp ra c s f tf tc,
+      Genv.find_funct_ptr ge fb = Some (Internal f) ->
+      transl_code_at_pc ge ra fb f c false tf tc ->
+      sp <> Vundef ->
+      match_stack s ->
+      match_stack (Stackframe fb sp ra c :: s).
+
+Lemma parent_sp_def: forall s, match_stack s -> parent_sp s <> Vundef.
+Proof.
+  induction 1; simpl.
+  unfold Vnullptr; destruct Archi.ptr64; congruence.
+  auto.
+Qed.
+
+Lemma parent_ra_def: forall s, match_stack s -> parent_ra s <> Vundef.
+Proof.
+  induction 1; simpl.
+  unfold Vnullptr; destruct Archi.ptr64; congruence.
+  inv H0. congruence.
+Qed.
+
+Lemma lessdef_parent_sp:
+  forall s v,
+  match_stack s -> Val.lessdef (parent_sp s) v -> v = parent_sp s.
+Proof.
+  intros. inv H0. auto. exploit parent_sp_def; eauto. tauto.
+Qed.
+
+Lemma lessdef_parent_ra:
+  forall s v,
+  match_stack s -> Val.lessdef (parent_ra s) v -> v = parent_ra s.
+Proof.
+  intros. inv H0. auto. exploit parent_ra_def; eauto. tauto.
+Qed.
+
+End MATCH_STACK.
\ No newline at end of file
diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v
new file mode 100644
index 00000000..d0c205cd
--- /dev/null
+++ b/mppa_k1c/Asmblockgenproof1.v
@@ -0,0 +1,1633 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              The Compcert verified compiler                         *)
+(*                                                                     *)
+(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
+(*           Prashanth Mundkur, SRI International                      *)
+(*                                                                     *)
+(*  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.     *)
+(*                                                                     *)
+(*  The contributions by Prashanth Mundkur are reused and adapted      *)
+(*  under the terms of a Contributor License Agreement between         *)
+(*  SRI International and INRIA.                                       *)
+(*                                                                     *)
+(* *********************************************************************)
+
+Require Import Coqlib Errors Maps.
+Require Import AST Integers Floats Values Memory Globalenvs.
+Require Import Op Locations Machblock Conventions.
+Require Import Asmblock Asmblockgen Asmblockgenproof0.
+
+(** Decomposition of integer constants. *)
+
+Lemma make_immed32_sound:
+  forall n,
+  match make_immed32 n with
+  | Imm32_single imm => n = imm
+  end.
+Proof.
+  intros; unfold make_immed32. set (lo := Int.sign_ext 12 n).
+  predSpec Int.eq Int.eq_spec n lo; auto.
+(*
+- auto.
+- set (m := Int.sub n lo).
+  assert (A: Int.eqmod (two_p 12) (Int.unsigned lo) (Int.unsigned n)) by (apply Int.eqmod_sign_ext'; compute; auto).
+  assert (B: Int.eqmod (two_p 12) (Int.unsigned n - Int.unsigned  lo) 0).
+  { replace 0 with (Int.unsigned n - Int.unsigned n) by omega.
+    auto using Int.eqmod_sub, Int.eqmod_refl. }
+  assert (C: Int.eqmod (two_p 12) (Int.unsigned m) 0).
+  { apply Int.eqmod_trans with (Int.unsigned n - Int.unsigned lo); auto.
+    apply Int.eqmod_divides with Int.modulus. apply Int.eqm_sym; apply Int.eqm_unsigned_repr.
+    exists (two_p (32-12)); auto. }
+  assert (D: Int.modu m (Int.repr 4096) = Int.zero).
+  { apply Int.eqmod_mod_eq in C. unfold Int.modu. 
+    change (Int.unsigned (Int.repr 4096)) with (two_p 12). rewrite C. 
+    reflexivity.
+    apply two_p_gt_ZERO; omega. }
+  rewrite <- (Int.divu_pow2 m (Int.repr 4096) (Int.repr 12)) by auto.
+  rewrite Int.shl_mul_two_p. 
+  change (two_p (Int.unsigned (Int.repr 12))) with 4096.
+  replace (Int.mul (Int.divu m (Int.repr 4096)) (Int.repr 4096)) with m.
+  unfold m. rewrite Int.sub_add_opp. rewrite Int.add_assoc. rewrite <- (Int.add_commut lo).
+  rewrite Int.add_neg_zero. rewrite Int.add_zero. auto.
+  rewrite (Int.modu_divu_Euclid m (Int.repr 4096)) at 1 by (vm_compute; congruence).
+  rewrite D. apply Int.add_zero.
+*)
+Qed.
+
+Lemma make_immed64_sound:
+  forall n,
+  match make_immed64 n with
+  | Imm64_single imm => n = imm
+(*| Imm64_pair hi lo => n = Int64.add (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))) lo
+  | Imm64_large imm => n = imm
+*)end.
+Proof.
+  intros; unfold make_immed64. set (lo := Int64.sign_ext 12 n).
+  predSpec Int64.eq Int64.eq_spec n lo.
+- auto.
+- set (m := Int64.sub n lo).
+  set (p := Int64.zero_ext 20 (Int64.shru m (Int64.repr 12))).
+  predSpec Int64.eq Int64.eq_spec n (Int64.add (Int64.sign_ext 32 (Int64.shl p (Int64.repr 12))) lo).
+  auto.
+  auto.
+Qed.
+
+
+
+(** Properties of registers *)
+
+Lemma ireg_of_not_GPR31:
+  forall m r, ireg_of m = OK r -> IR r <> IR GPR31.
+Proof.
+  intros. erewrite <- ireg_of_eq; eauto with asmgen.
+Qed.
+
+Lemma ireg_of_not_GPR31':
+  forall m r, ireg_of m = OK r -> r <> GPR31.
+Proof.
+  intros. apply ireg_of_not_GPR31 in H. congruence.
+Qed.
+
+Hint Resolve ireg_of_not_GPR31 ireg_of_not_GPR31': asmgen.
+
+
+(** Useful simplification tactic *)
+
+Ltac Simplif :=
+  ((rewrite nextblock_inv by eauto with asmgen)
+  || (rewrite nextblock_inv1 by eauto with asmgen)
+  || (rewrite Pregmap.gss)
+  || (rewrite nextblock_pc)
+  || (rewrite Pregmap.gso by eauto with asmgen)
+  ); auto with asmgen.
+
+Ltac Simpl := repeat Simplif.
+
+(** * Correctness of RISC-V constructor functions *)
+
+Section CONSTRUCTORS.
+
+Variable ge: genv.
+Variable fn: function.
+
+(*
+(** 32-bit integer constants and arithmetic *)
+(*
+Lemma load_hilo32_correct:
+  forall rd hi lo k rs m,
+  exists rs',
+     exec_straight ge fn (load_hilo32 rd hi lo k) rs m k rs' m
+  /\ rs'#rd = Vint (Int.add (Int.shl hi (Int.repr 12)) lo)
+  /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r.
+Proof.
+  unfold load_hilo32; intros. 
+  predSpec Int.eq Int.eq_spec lo Int.zero.
+- subst lo. econstructor; split. 
+  apply exec_straight_one. simpl; eauto. auto.
+  split. rewrite Int.add_zero. Simpl.
+  intros; Simpl.
+- econstructor; split.
+  eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. 
+  split. Simpl. 
+  intros; Simpl.
+Qed.
+*)
+
+*)
+
+Lemma loadimm32_correct:
+  forall rd n k rs m,
+  exists rs',
+     exec_straight ge (loadimm32 rd n ::g k) rs m k rs' m
+  /\ rs'#rd = Vint n
+  /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r.
+Proof.
+  unfold loadimm32; intros. generalize (make_immed32_sound n); intros E.
+  destruct (make_immed32 n). 
+- subst imm. econstructor; split. 
+  apply exec_straight_one. simpl; eauto. auto.
+  split. Simpl.
+  intros; Simpl.
+Qed.
+
+Lemma loadimm64_correct:
+  forall rd n k rs m,
+  exists rs',
+     exec_straight ge (loadimm64 rd n ::g k) rs m k rs' m
+  /\ rs'#rd = Vlong n
+  /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r.
+Proof.
+  unfold loadimm64; intros. generalize (make_immed64_sound n); intros E.
+  destruct (make_immed64 n). 
+- subst imm. econstructor; split. 
+  apply exec_straight_one. simpl; eauto. auto.
+  split. Simpl. 
+  intros; Simpl.
+Qed.
+
+(*
+(*
+Lemma opimm32_correct:
+  forall (op: ireg -> ireg0 -> ireg0 -> instruction)
+         (opi: ireg -> ireg0 -> int -> instruction)
+         (sem: val -> val -> val) m,
+  (forall d s1 s2 rs,
+   exec_instr ge fn (op d s1 s2) rs m = Next (nextinstr (rs#d <- (sem rs##s1 rs##s2))) m) ->
+  (forall d s n rs,
+   exec_instr ge fn (opi d s n) rs m = Next (nextinstr (rs#d <- (sem rs##s (Vint n)))) m) ->
+  forall rd r1 n k rs,
+  r1 <> GPR31 ->
+  exists rs',
+     exec_straight ge fn (opimm32 op opi rd r1 n k) rs m k rs' m
+  /\ rs'#rd = sem rs##r1 (Vint n)
+  /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r.
+Proof.
+  intros. unfold opimm32. generalize (make_immed32_sound n); intros E.
+  destruct (make_immed32 n). 
+- subst imm. econstructor; split. 
+  apply exec_straight_one. rewrite H0. simpl; eauto. auto.
+  split. Simpl. intros; Simpl.
+- destruct (load_hilo32_correct GPR31 hi lo (op rd r1 GPR31 :: k) rs m)
+  as (rs' & A & B & C).
+  econstructor; split.
+  eapply exec_straight_trans. eexact A. apply exec_straight_one. 
+  rewrite H; eauto. auto.
+  split. Simpl. simpl. rewrite B, C, E. auto. congruence. congruence.
+  intros; Simpl. 
+Qed.
+
+(** 64-bit integer constants and arithmetic *)
+
+Lemma load_hilo64_correct:
+  forall rd hi lo k rs m,
+  exists rs',
+     exec_straight ge fn (load_hilo64 rd hi lo k) rs m k rs' m
+  /\ rs'#rd = Vlong (Int64.add (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))) lo)
+  /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r.
+Proof.
+  unfold load_hilo64; intros. 
+  predSpec Int64.eq Int64.eq_spec lo Int64.zero.
+- subst lo. econstructor; split. 
+  apply exec_straight_one. simpl; eauto. auto.
+  split. rewrite Int64.add_zero. Simpl.
+  intros; Simpl.
+- econstructor; split.
+  eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. 
+  split. Simpl. 
+  intros; Simpl.
+Qed.
+*)
+*)
+
+Definition yolo := 4.
+
+Lemma opimm64_correct:
+  forall (op: arith_name_rrr)
+         (opi: arith_name_rri64)
+         (sem: val -> val -> val) m,
+  (forall d s1 s2 rs,
+   exec_basic_instr ge (op d s1 s2) rs m = Next ((rs#d <- (sem rs#s1 rs#s2))) m) ->
+  (forall d s n rs,
+   exec_basic_instr ge (opi d s n) rs m = Next ((rs#d <- (sem rs#s (Vlong n)))) m) ->
+  forall rd r1 n k rs,
+  r1 <> GPR31 ->
+  exists rs',
+     exec_straight ge (opimm64 op opi rd r1 n ::g k) rs m k rs' m
+  /\ rs'#rd = sem rs#r1 (Vlong n)
+  /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r.
+Proof.
+  intros. unfold opimm64. generalize (make_immed64_sound n); intros E.
+  destruct (make_immed64 n). 
+- subst imm. econstructor; split. 
+  apply exec_straight_one. rewrite H0. simpl; eauto. auto.
+  split. Simpl. intros; Simpl.
+(*
+- destruct (load_hilo64_correct GPR31 hi lo (op rd r1 GPR31 :: k) rs m)
+  as (rs' & A & B & C).
+  econstructor; split.
+  eapply exec_straight_trans. eexact A. apply exec_straight_one. 
+  rewrite H; eauto. auto.
+  split. Simpl. simpl. rewrite B, C, E. auto. congruence. congruence.
+  intros; Simpl. 
+- subst imm. econstructor; split. 
+  eapply exec_straight_two. simpl; eauto. rewrite H. simpl; eauto. auto. auto.
+  split. Simpl. intros; Simpl.
+*)
+Qed.
+
+(** Add offset to pointer *)
+
+Lemma addptrofs_correct:
+  forall rd r1 n k rs m,
+  r1 <> GPR31 ->
+  exists rs',
+     exec_straight ge (addptrofs rd r1 n ::g k) rs m k rs' m
+  /\ Val.lessdef (Val.offset_ptr rs#r1 n) rs'#rd
+  /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r.
+Proof.
+  unfold addptrofs; intros.
+  destruct (Ptrofs.eq_dec n Ptrofs.zero).
+- subst n. econstructor; split.
+  apply exec_straight_one. simpl; eauto. auto.
+  split. Simpl. destruct (rs r1); simpl; auto. rewrite Ptrofs.add_zero; auto.
+  intros; Simpl.
+- unfold addimm64.
+  exploit (opimm64_correct Paddl Paddil Val.addl); eauto. intros (rs' & A & B & C).
+  exists rs'; split. eexact A. split; auto.
+  rewrite B. destruct (rs r1); simpl; auto.
+  rewrite Ptrofs.of_int64_to_int64 by auto. auto.
+Qed.
+
+(*
+(*
+Lemma addptrofs_correct_2:
+  forall rd r1 n k (rs: regset) m b ofs,
+  r1 <> GPR31 -> rs#r1 = Vptr b of
+s ->
+  exists rs',
+     exec_straight ge fn (addptrofs rd r1 n k) rs m k rs' m
+  /\ rs'#rd = Vptr b (Ptrofs.add ofs n)
+  /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r.
+Proof.
+  intros. exploit (addptrofs_correct rd r1 n); eauto. intros (rs' & A & B & C).
+  exists rs'; intuition eauto. 
+  rewrite H0 in B. inv B. auto.
+Qed.
+
+(** Translation of conditional branches *)
+
+Remark branch_on_GPR31:
+  forall normal lbl (rs: regset) m b,
+  rs#GPR31 = Val.of_bool (eqb normal b) ->
+  exec_instr ge fn (if normal then Pbnew GPR31 X0 lbl else Pbeqw GPR31 X0 lbl) rs m =
+  eval_branch fn lbl rs m (Some b).
+Proof.
+  intros. destruct normal; simpl; rewrite H; simpl; destruct b; reflexivity. 
+Qed.
+*)
+*)
+
+Ltac ArgsInv :=
+  repeat (match goal with
+  | [ H: Error _ = OK _ |- _ ] => discriminate
+  | [ H: match ?args with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct args
+  | [ H: bind _ _ = OK _ |- _ ] => monadInv H
+  | [ H: match _ with left _ => _ | right _ => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv
+  | [ H: match _ with true => _ | false => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv
+  end);
+  subst;
+  repeat (match goal with
+  | [ H: ireg_of _ = OK _ |- _ ] => simpl in *; rewrite (ireg_of_eq _ _ H) in *
+  | [ H: freg_of _ = OK _ |- _ ] => simpl in *; rewrite (freg_of_eq _ _ H) in *
+  end).
+
+Inductive exec_straight_opt: list instruction -> regset -> mem -> list instruction -> regset -> mem -> Prop :=
+  | exec_straight_opt_refl: forall c rs m,
+      exec_straight_opt c rs m c rs m
+  | exec_straight_opt_intro: forall c1 rs1 m1 c2 rs2 m2,
+      exec_straight ge c1 rs1 m1 c2 rs2 m2 ->
+      exec_straight_opt c1 rs1 m1 c2 rs2 m2.
+
+Remark exec_straight_opt_right:
+  forall c3 rs3 m3 c1 rs1 m1 c2 rs2 m2,
+  exec_straight_opt c1 rs1 m1 c2 rs2 m2 ->
+  exec_straight ge c2 rs2 m2 c3 rs3 m3 ->
+  exec_straight ge c1 rs1 m1 c3 rs3 m3.
+Proof.
+  destruct 1; intros. auto. eapply exec_straight_trans; eauto. 
+Qed.
+
+Lemma transl_comp_correct:
+  forall cmp r1 r2 lbl k rs m tbb b,
+  exists rs',
+     exec_straight ge (transl_comp cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::g k) rs' m
+  /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r)  
+  /\ ( Val.cmp_bool cmp rs#r1 rs#r2 = Some b ->
+       exec_control ge fn (Some (PCtlFlow (Pcb BTwnez GPR31 lbl))) (nextblock tbb rs') m
+        = eval_branch fn lbl (nextblock tbb rs') m (Some b))
+  .
+Proof.
+  intros. esplit. split.
+- unfold transl_comp. apply exec_straight_one; simpl; eauto.
+- split.
+  + intros; Simpl.
+  + intros.
+    remember (rs # GPR31 <- (compare_int (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)) as rs'.
+    simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # GPR31 (Vint (Int.repr 0)) = Some b).
+    { 
+      assert ((nextblock tbb rs') # GPR31 = (compare_int (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)).
+      { rewrite Heqrs'. auto. }
+      rewrite H0. rewrite <- H.
+      remember (Val.cmp_bool cmp rs#r1 rs#r2) as cmpbool.
+      destruct cmp; simpl;
+      unfold Val.cmp; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto;
+      destruct b0; simpl; auto.
+    }
+    rewrite H0. simpl; auto.
+Qed.
+
+Lemma transl_compu_correct:
+  forall cmp r1 r2 lbl k rs m tbb b,
+  exists rs',
+     exec_straight ge (transl_comp cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::g k) rs' m
+  /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r)  
+  /\ ( Val.cmpu_bool (Mem.valid_pointer m) cmp rs#r1 rs#r2 = Some b ->
+       exec_control ge fn (Some (PCtlFlow ((Pcb BTwnez GPR31 lbl)))) (nextblock tbb rs') m
+        = eval_branch fn lbl (nextblock tbb rs') m (Some b))
+  .
+Proof.
+  intros. esplit. split.
+- unfold transl_comp. apply exec_straight_one; simpl; eauto.
+- split.
+  + intros; Simpl.
+  + intros.
+    remember (rs # GPR31 <- (compare_int (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)) as rs'.
+    simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # GPR31 (Vint (Int.repr 0)) = Some b).
+    { 
+      assert ((nextblock tbb rs') # GPR31 = (compare_int (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)).
+      { rewrite Heqrs'. auto. }
+      rewrite H0. rewrite <- H.
+      remember (Val.cmpu_bool (Mem.valid_pointer m) cmp rs#r1 rs#r2) as cmpubool.
+      destruct cmp; simpl; unfold Val.cmpu; rewrite <- Heqcmpubool; destruct cmpubool; simpl; auto;
+      destruct b0; simpl; auto.
+    }
+    rewrite H0. simpl; auto.
+Qed.
+
+Lemma transl_compl_correct:
+  forall cmp r1 r2 lbl k rs m tbb b,
+  exists rs',
+     exec_straight ge (transl_compl cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::g k) rs' m
+  /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r)  
+  /\ ( Val.cmpl_bool cmp rs#r1 rs#r2 = Some b ->
+       exec_control ge fn (Some (PCtlFlow (Pcb BTwnez GPR31 lbl))) (nextblock tbb rs') m
+        = eval_branch fn lbl (nextblock tbb rs') m (Some b))
+  .
+Proof.
+  intros. esplit. split.
+- unfold transl_compl. apply exec_straight_one; simpl; eauto.
+- split.
+  + intros; Simpl.
+  + intros.
+    remember (rs # GPR31 <- (compare_long (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)) as rs'.
+    simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # GPR31 (Vint (Int.repr 0)) = Some b).
+    { 
+      assert ((nextblock tbb rs') # GPR31 = (compare_long (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)).
+      { rewrite Heqrs'. auto. }
+      rewrite H0. rewrite <- H.
+      remember (Val.cmpl_bool cmp rs#r1 rs#r2) as cmpbool.
+      destruct cmp; simpl;
+      unfold compare_long;
+      unfold Val.cmpl; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto;
+      destruct b0; simpl; auto.
+    }
+    rewrite H0. simpl; auto.
+Qed.
+
+Lemma transl_complu_correct:
+  forall cmp r1 r2 lbl k rs m tbb b,
+  exists rs',
+     exec_straight ge (transl_compl cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::g k) rs' m
+  /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r)  
+  /\ ( Val.cmplu_bool (Mem.valid_pointer m) cmp rs#r1 rs#r2 = Some b ->
+       exec_control ge fn (Some (PCtlFlow (Pcb BTwnez GPR31 lbl))) (nextblock tbb rs') m
+        = eval_branch fn lbl (nextblock tbb rs') m (Some b))
+  .
+Proof.
+  intros. esplit. split.
+- unfold transl_compl. apply exec_straight_one; simpl; eauto.
+- split.
+  + intros; Simpl.
+  + intros.
+    remember (rs # GPR31 <- (compare_long (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)) as rs'.
+    simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # GPR31 (Vint (Int.repr 0)) = Some b).
+    { 
+      assert ((nextblock tbb rs') # GPR31 = (compare_long (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)).
+      { rewrite Heqrs'. auto. }
+      rewrite H0. rewrite <- H.
+      remember (Val.cmplu_bool (Mem.valid_pointer m) cmp rs#r1 rs#r2) as cmpbool.
+      destruct cmp; simpl;
+      unfold compare_long;
+      unfold Val.cmplu; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto;
+      destruct b0; simpl; auto.
+    }
+    rewrite H0. simpl; auto.
+Qed.
+
+Lemma transl_opt_compuimm_correct:
+  forall n cmp r1 lbl k rs m b tbb c,
+  select_comp n cmp = Some c ->
+  exists rs', exists insn,
+     exec_straight_opt (transl_opt_compuimm n cmp r1 lbl k) rs m ((PControl insn) ::g k) rs' m
+  /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r)  
+  /\ ( Val.cmpu_bool (Mem.valid_pointer m) cmp rs#r1 (Vint n) = Some b ->
+       exec_control ge fn (Some insn) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b))
+  .
+Proof.
+  intros.
+(*   unfold transl_opt_compuimm. unfold select_comp in H. rewrite H; simpl. *)
+  remember c as c'.
+  destruct c'.
+  - (* c = Ceq *)
+    assert (Int.eq n Int.zero = true) as H'. 
+    { remember (Int.eq n Int.zero) as termz. destruct termz; auto.
+      generalize H. unfold select_comp; rewrite <- Heqtermz; simpl.
+      discriminate. }
+    assert (n = (Int.repr 0)) as H0. { 
+      destruct (Int.eq_dec n (Int.repr 0)) as [Ha|Ha]; auto. 
+      generalize (Int.eq_false _ _ Ha).  unfold Int.zero in H'.
+      rewrite H'. discriminate.
+    }
+    assert (Ceq = cmp). { 
+      remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_comp;
+      rewrite H'; simpl; auto;
+      intros; contradict H; discriminate.
+    }
+    unfold transl_opt_compuimm. subst. rewrite H'.
+
+    exists rs, (Pcbu BTweqz r1 lbl).
+    split.
+    * constructor.
+    * split; auto. simpl. intros.
+      assert (rs r1 = (nextblock tbb rs) r1).
+        unfold nextblock. Simpl. rewrite H1 in H0.
+      (*assert (Val.cmp_bool Ceq (rs r1) (Vint (Int.repr 0)) = Some b) as EVAL'S.
+      { rewrite <- H2. rewrite <- H0. rewrite <- H1. auto. }*)
+      auto;
+      unfold eval_branch. rewrite H0; auto.
+  - (* c = Cne *)
+    assert (Int.eq n Int.zero = true) as H'. 
+    { remember (Int.eq n Int.zero) as termz. destruct termz; auto.
+      generalize H. unfold select_comp; rewrite <- Heqtermz; simpl.
+      discriminate. }
+    assert (n = (Int.repr 0)) as H0. { 
+      destruct (Int.eq_dec n (Int.repr 0)) as [Ha|Ha]; auto. 
+      generalize (Int.eq_false _ _ Ha).  unfold Int.zero in H'.
+      rewrite H'. discriminate.
+    }
+    assert (Cne = cmp). { 
+      remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_comp;
+      rewrite H'; simpl; auto;
+      intros; contradict H; discriminate.
+    }
+    unfold transl_opt_compuimm. subst. rewrite H'.
+
+    exists rs, (Pcbu BTwnez r1 lbl).
+    split.
+    * constructor.
+    * split; auto. simpl. intros.
+      assert (rs r1 = (nextblock tbb rs) r1).
+        unfold nextblock. Simpl. rewrite H1 in H0.
+      auto;
+      unfold eval_branch. rewrite H0. auto.
+  - (* c = Clt *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero);
+    destruct cmp; discriminate.
+  - (* c = Cle *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero);
+    destruct cmp; discriminate.
+  - (* c = Cgt *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero);
+    destruct cmp; discriminate.
+  - (* c = Cge *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero);
+    destruct cmp; discriminate.
+Qed.
+
+Lemma transl_opt_compluimm_correct:
+  forall n cmp r1 lbl k rs m b tbb c,
+  select_compl n cmp = Some c ->
+  exists rs', exists insn,
+     exec_straight_opt (transl_opt_compluimm n cmp r1 lbl k) rs m ((PControl insn) ::g k) rs' m
+  /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r)
+  /\ ( Val.cmplu_bool (Mem.valid_pointer m) cmp rs#r1 (Vlong n) = Some b ->
+       exec_control ge fn (Some insn) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b))
+  .
+Proof.
+  intros.
+(*   unfold transl_opt_compluimm; rewrite H; simpl. *)
+  remember c as c'.
+  destruct c'.
+  - (* c = Ceq *)
+    assert (Int64.eq n Int64.zero = true) as H'. 
+    { remember (Int64.eq n Int64.zero) as termz. destruct termz; auto.
+      generalize H. unfold select_compl; rewrite <- Heqtermz; simpl.
+      discriminate. }
+    assert (n = (Int64.repr 0)) as H0. { 
+      destruct (Int64.eq_dec n (Int64.repr 0)) as [Ha|Ha]; auto. 
+      generalize (Int64.eq_false _ _ Ha).  unfold Int64.zero in H'.
+      rewrite H'. discriminate.
+    }
+    assert (Ceq = cmp). { 
+      remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_compl;
+      rewrite H'; simpl; auto;
+      intros; contradict H; discriminate.
+    }
+    unfold transl_opt_compluimm; subst; rewrite H'.
+
+    exists rs, (Pcbu BTdeqz r1 lbl).
+    split.
+    * constructor.
+    * split; auto. simpl. intros.
+      assert (rs r1 = (nextblock tbb rs) r1).
+        unfold nextblock. Simpl. rewrite H1 in H0.
+      auto;
+      unfold eval_branch. rewrite H0; auto.
+  - (* c = Cne *)
+    assert (Int64.eq n Int64.zero = true) as H'. 
+    { remember (Int64.eq n Int64.zero) as termz. destruct termz; auto.
+      generalize H. unfold select_compl; rewrite <- Heqtermz; simpl.
+      discriminate. }
+    assert (n = (Int64.repr 0)) as H0. { 
+      destruct (Int64.eq_dec n (Int64.repr 0)) as [Ha|Ha]; auto. 
+      generalize (Int64.eq_false _ _ Ha).  unfold Int64.zero in H'.
+      rewrite H'. discriminate.
+    }
+    assert (Cne = cmp). { 
+      remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_compl;
+      rewrite H'; simpl; auto;
+      intros; contradict H; discriminate.
+    }
+    unfold transl_opt_compluimm; subst; rewrite H'.
+
+    exists rs, (Pcbu BTdnez r1 lbl).
+    split.
+    * constructor.
+    * split; auto. simpl. intros.
+      assert (rs r1 = (nextblock tbb rs) r1).
+        unfold nextblock. Simpl. rewrite H1 in H0.
+      auto;
+      unfold eval_branch. rewrite H0; auto.
+  - (* c = Clt *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero);
+    destruct cmp; discriminate.
+  - (* c = Cle *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero);
+    destruct cmp; discriminate.
+  - (* c = Cgt *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero);
+    destruct cmp; discriminate.
+  - (* c = Cge *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero);
+    destruct cmp; discriminate.
+Qed.
+
+Lemma transl_cbranch_correct_1:
+  forall cond args lbl k c m ms b sp rs m' tbb,
+  transl_cbranch cond args lbl k = OK c ->
+  eval_condition cond (List.map ms args) m = Some b ->
+  agree ms sp rs ->
+  Mem.extends m m' ->
+  exists rs', exists insn,
+     exec_straight_opt c rs m' ((PControl insn) ::g k) rs' m'
+  /\ exec_control ge fn (Some insn) (nextblock tbb rs') m' = eval_branch fn lbl (nextblock tbb rs') m' (Some b)
+  /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r.
+Proof.
+  intros until tbb; intros TRANSL EVAL AG MEXT.
+  set (vl' := map rs (map preg_of args)). 
+  assert (EVAL': eval_condition cond vl' m' = Some b).
+  { apply eval_condition_lessdef with (map ms args) m; auto. eapply preg_vals; eauto. }
+  clear EVAL MEXT AG.
+  destruct cond; simpl in TRANSL; ArgsInv.
+(* Ccomp *)
+- exploit (transl_comp_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C).
+  exists rs', (Pcb BTwnez GPR31 lbl).
+  split.
+  + constructor. eexact A.
+  + split; auto. apply C; auto.
+(* Ccompu *)
+- exploit (transl_compu_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C).
+  exists rs', (Pcb BTwnez GPR31 lbl).
+  split.
+  + constructor. eexact A.
+  + split; auto. apply C; auto.
+(* Ccompimm *)
+- remember (Int.eq n Int.zero) as eqz.
+  destruct eqz.
+  + assert (n = (Int.repr 0)). { 
+        destruct (Int.eq_dec n (Int.repr 0)) as [H|H]; auto. 
+        generalize (Int.eq_false _ _ H).  unfold Int.zero in Heqeqz.
+        rewrite <- Heqeqz. discriminate.
+    }
+    exists rs, (Pcb (btest_for_cmpswz c0) x lbl).
+    split. 
+    * constructor.
+    * split; auto.
+      assert (rs x = (nextblock tbb rs) x).
+        unfold nextblock. Simpl. rewrite H0 in EVAL'. clear H0.
+      destruct c0; simpl; auto;
+      unfold eval_branch; rewrite <- H; rewrite EVAL'; auto.
+  + exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C).
+    exploit (transl_comp_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C').
+    exists rs'2, (Pcb BTwnez GPR31 lbl).
+    split.
+    * constructor. apply exec_straight_trans 
+         with (c2 := (transl_comp c0 Signed x GPR31 lbl k)) (rs2 := rs') (m2 := m').
+      eexact A. eexact A'.
+    * split; auto.
+      { apply C'; auto. rewrite B, C; eauto with asmgen. }
+      { intros. rewrite B'; eauto with asmgen. }
+(* Ccompuimm *)
+- remember (select_comp n c0) as selcomp.
+  destruct selcomp.
+  + exploit (transl_opt_compuimm_correct n c0 x lbl k). apply eq_sym. apply Heqselcomp.
+    intros (rs' & i & A & B & C).
+    exists rs', i.
+    split.
+    * apply A.
+    * split; auto. apply C. apply EVAL'.
+  + assert (transl_opt_compuimm n c0 x lbl k = loadimm32 GPR31 n ::g transl_comp c0 Unsigned x GPR31 lbl k).
+    { unfold transl_opt_compuimm.
+      destruct (Int.eq n Int.zero) eqn:EQN.
+      all: unfold select_comp in Heqselcomp; rewrite EQN in Heqselcomp; destruct c0; simpl in *; auto.
+      all: discriminate. }
+    rewrite H. clear H.
+    exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C).
+    exploit (transl_compu_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C').
+    exists rs'2, (Pcb BTwnez GPR31 lbl).
+    split.
+    * constructor. apply exec_straight_trans 
+         with (c2 := (transl_comp c0 Unsigned x GPR31 lbl k)) (rs2 := rs') (m2 := m').
+      eexact A. eexact A'.
+    * split; auto.
+      { apply C'; auto. rewrite B, C; eauto with asmgen. }
+      { intros. rewrite B'; eauto with asmgen. }
+(* Ccompl *)
+- exploit (transl_compl_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C).
+  exists rs', (Pcb BTwnez GPR31 lbl).
+  split.
+  + constructor. eexact A.
+  + split; auto. apply C; auto.
+(* Ccomplu *)
+- exploit (transl_complu_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C).
+  exists rs', (Pcb BTwnez GPR31 lbl).
+  split.
+  + constructor. eexact A.
+  + split; auto. apply C; auto.
+(* Ccomplimm *)
+- remember (Int64.eq n Int64.zero) as eqz.
+  destruct eqz.
+  + assert (n = (Int64.repr 0)). { 
+        destruct (Int64.eq_dec n (Int64.repr 0)) as [H|H]; auto. 
+        generalize (Int64.eq_false _ _ H).  unfold Int64.zero in Heqeqz.
+        rewrite <- Heqeqz. discriminate.
+    }
+    exists rs, (Pcb (btest_for_cmpsdz c0) x lbl).
+    split. 
+    * constructor.
+    * split; auto.
+      assert (rs x = (nextblock tbb rs) x).
+        unfold nextblock. Simpl. rewrite H0 in EVAL'. clear H0.
+      destruct c0; simpl; auto;
+      unfold eval_branch; rewrite <- H; rewrite EVAL'; auto.
+  + exploit (loadimm64_correct GPR31 n); eauto. intros (rs' & A & B & C).
+    exploit (transl_compl_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C').
+    exists rs'2, (Pcb BTwnez GPR31 lbl).
+    split.
+    * constructor. apply exec_straight_trans 
+         with (c2 := (transl_compl c0 Signed x GPR31 lbl k)) (rs2 := rs') (m2 := m').
+      eexact A. eexact A'.
+    * split; auto.
+      { apply C'; auto. rewrite B, C; eauto with asmgen. }
+      { intros. rewrite B'; eauto with asmgen. }
+
+(* Ccompluimm *)
+- remember (select_compl n c0) as selcomp.
+  destruct selcomp.
+  + exploit (transl_opt_compluimm_correct n c0 x lbl k). apply eq_sym. apply Heqselcomp.
+    intros (rs' & i & A & B & C).
+    exists rs', i.
+    split.
+    * apply A.
+    * split; auto. apply C. apply EVAL'.
+  + assert (transl_opt_compluimm n c0 x lbl k = loadimm64 GPR31 n ::g transl_compl c0 Unsigned x GPR31 lbl k).
+    { unfold transl_opt_compluimm.
+      destruct (Int64.eq n Int64.zero) eqn:EQN.
+      all: unfold select_compl in Heqselcomp; rewrite EQN in Heqselcomp; destruct c0; simpl in *; auto.
+      all: discriminate. }
+    rewrite H. clear H.
+    exploit (loadimm64_correct GPR31 n); eauto. intros (rs' & A & B & C).
+    exploit (transl_complu_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C').
+    exists rs'2, (Pcb BTwnez GPR31 lbl).
+    split.
+    * constructor. apply exec_straight_trans 
+         with (c2 := (transl_compl c0 Unsigned x GPR31 lbl k)) (rs2 := rs') (m2 := m').
+      eexact A. eexact A'.
+    * split; auto.
+      { apply C'; auto. rewrite B, C; eauto with asmgen. }
+      { intros. rewrite B'; eauto with asmgen. }
+Qed.
+
+Lemma transl_cbranch_correct_true:
+  forall cond args lbl k c m ms sp rs m' tbb,
+  transl_cbranch cond args lbl k = OK c ->
+  eval_condition cond (List.map ms args) m = Some true ->
+  agree ms sp rs ->
+  Mem.extends m m' ->
+  exists rs', exists insn,
+     exec_straight_opt c rs m' ((PControl insn) ::g k) rs' m'
+  /\ exec_control ge fn (Some insn) (nextblock tbb rs') m' = goto_label fn lbl (nextblock tbb rs') m'
+  /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r.
+Proof.
+  intros. eapply transl_cbranch_correct_1 with (b := true); eauto.
+Qed. 
+
+Lemma transl_cbranch_correct_false:
+  forall cond args lbl k c m ms sp rs tbb m',
+  transl_cbranch cond args lbl k = OK c ->
+  eval_condition cond (List.map ms args) m = Some false ->
+  agree ms sp rs ->
+  Mem.extends m m' ->
+  exists rs', exists insn,
+     exec_straight_opt c rs m' ((PControl insn) ::g k) rs' m'
+  /\ exec_control ge fn (Some insn) (nextblock tbb rs') m' = Next (nextblock tbb rs') m'
+  /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r.
+Proof.
+  intros. exploit transl_cbranch_correct_1; eauto.
+Qed.
+(*   intros (rs' & insn & A & B & C).
+  exists rs'.
+  split. eapply exec_straight_opt_right; eauto. apply exec_straight_one; auto.
+  intros; Simpl. 
+ *)
+
+(** Translation of condition operators *)
+
+Lemma transl_cond_int32s_correct:
+  forall cmp rd r1 r2 k rs m,
+  exists rs',
+     exec_straight ge (basics_to_code (transl_cond_int32s cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m
+  /\ Val.lessdef (Val.cmp cmp rs#r1 rs#r2) rs'#rd
+  /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. 
+Proof.
+  intros. destruct cmp; simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+Qed.
+
+Lemma transl_cond_int32u_correct:
+  forall cmp rd r1 r2 k rs m,
+  exists rs',
+     exec_straight ge (basics_to_code (transl_cond_int32u cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m
+  /\ rs'#rd = Val.cmpu (Mem.valid_pointer m) cmp rs#r1 rs#r2
+  /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. 
+Proof.
+  intros. destruct cmp; simpl. 
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+Qed.
+
+Lemma transl_cond_int64s_correct:
+  forall cmp rd r1 r2 k rs m,
+  exists rs',
+     exec_straight ge (basics_to_code (transl_cond_int64s cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m
+  /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs#r1 rs#r2)) rs'#rd
+  /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. 
+Proof.
+  intros. destruct cmp; simpl. 
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+Qed.
+
+Lemma transl_cond_int64u_correct:
+  forall cmp rd r1 r2 k rs m,
+  exists rs',
+     exec_straight ge (basics_to_code (transl_cond_int64u cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m
+  /\ rs'#rd = Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs#r1 rs#r2)
+  /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. 
+Proof.
+  intros. destruct cmp; simpl. 
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+Qed.
+
+Lemma transl_condimm_int32s_correct:
+  forall cmp rd r1 n k rs m,
+  r1 <> GPR31 ->
+  exists rs',
+     exec_straight ge (basics_to_code (transl_condimm_int32s cmp rd r1 n k)) rs m (basics_to_code k) rs' m
+  /\ Val.lessdef (Val.cmp cmp rs#r1 (Vint n)) rs'#rd
+  /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r.
+Proof.
+  intros. destruct cmp; simpl. 
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+Qed.
+
+Lemma transl_condimm_int32u_correct:
+  forall cmp rd r1 n k rs m,
+  r1 <> GPR31 ->
+  exists rs',
+     exec_straight ge (basics_to_code (transl_condimm_int32u cmp rd r1 n k)) rs m (basics_to_code k) rs' m
+  /\ Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp rs#r1 (Vint n)) rs'#rd
+  /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r.
+Proof.
+  intros. destruct cmp; simpl. 
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+Qed.
+
+Lemma transl_condimm_int64s_correct:
+  forall cmp rd r1 n k rs m,
+  r1 <> GPR31 ->
+  exists rs',
+     exec_straight ge (basics_to_code (transl_condimm_int64s cmp rd r1 n k)) rs m (basics_to_code k) rs' m
+  /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs#r1 (Vlong n))) rs'#rd
+  /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r.
+Proof.
+  intros. destruct cmp; simpl. 
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+Qed.
+
+Lemma transl_condimm_int64u_correct:
+  forall cmp rd r1 n k rs m,
+  r1 <> GPR31 ->
+  exists rs',
+     exec_straight ge (basics_to_code (transl_condimm_int64u cmp rd r1 n k)) rs m (basics_to_code k) rs' m
+  /\ Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs#r1 (Vlong n))) rs'#rd
+  /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r.
+Proof.
+  intros. destruct cmp; simpl. 
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+- econstructor; split. apply exec_straight_one; [simpl; eauto].
+  split; intros; Simpl.
+Qed.
+
+Lemma transl_cond_op_correct:
+  forall cond rd args k c rs m,
+  transl_cond_op cond rd args k = OK c ->
+  exists rs',
+     exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m
+  /\ Val.lessdef (Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)) rs'#rd
+  /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r.
+Proof.
+  assert (MKTOT: forall ob, Val.of_optbool ob = Val.maketotal (option_map Val.of_bool ob)).
+  { destruct ob as [[]|]; reflexivity. }
+  intros until m; intros TR.
+  destruct cond; simpl in TR; ArgsInv.
++ (* cmp *)
+  exploit transl_cond_int32s_correct; eauto. simpl. intros (rs' & A & B & C). exists rs'; eauto.
++ (* cmpu *)
+  exploit transl_cond_int32u_correct; eauto. simpl. intros (rs' & A & B & C).
+  exists rs'; repeat split; eauto. rewrite B; auto.
++ (* cmpimm *)
+  apply transl_condimm_int32s_correct; eauto with asmgen.
++ (* cmpuimm *)
+  apply transl_condimm_int32u_correct; eauto with asmgen.
++ (* cmpl *)
+  exploit transl_cond_int64s_correct; eauto. simpl. intros (rs' & A & B & C).
+  exists rs'; repeat split; eauto. rewrite MKTOT; eauto.
++ (* cmplu *)
+  exploit transl_cond_int64u_correct; eauto. simpl. intros (rs' & A & B & C).
+  exists rs'; repeat split; eauto. rewrite B, MKTOT; eauto.
++ (* cmplimm *)
+  exploit transl_condimm_int64s_correct; eauto. instantiate (1 := x); eauto with asmgen. simpl. 
+  intros (rs' & A & B & C).
+  exists rs'; repeat split; eauto. rewrite MKTOT; eauto.
++ (* cmpluimm *)
+  exploit transl_condimm_int64u_correct; eauto. instantiate (1 := x); eauto with asmgen. simpl. 
+  intros (rs' & A & B & C).
+  exists rs'; repeat split; eauto. rewrite MKTOT; eauto.
+Qed.
+
+(*
+(*
++ (* cmpf *)
+  destruct (transl_cond_float c0 rd x x0) as [insn normal] eqn:TR.
+  fold (Val.cmpf c0 (rs x) (rs x0)).
+  set (v := Val.cmpf c0 (rs x) (rs x0)).
+  destruct normal; inv EQ2.
+* econstructor; split.
+  apply exec_straight_one. eapply transl_cond_float_correct with (v := v); eauto. auto.
+  split; intros; Simpl.
+* econstructor; split.
+  eapply exec_straight_two.
+  eapply transl_cond_float_correct with (v := Val.notbool v); eauto.
+  simpl; reflexivity.
+  auto. auto.
+  split; intros; Simpl. unfold v, Val.cmpf. destruct (Val.cmpf_bool c0 (rs x) (rs x0)) as [[]|]; auto.
++ (* notcmpf *)
+  destruct (transl_cond_float c0 rd x x0) as [insn normal] eqn:TR.
+  rewrite Val.notbool_negb_3. fold (Val.cmpf c0 (rs x) (rs x0)).
+  set (v := Val.cmpf c0 (rs x) (rs x0)).
+  destruct normal; inv EQ2.
+* econstructor; split.
+  eapply exec_straight_two.
+  eapply transl_cond_float_correct with (v := v); eauto.
+  simpl; reflexivity.
+  auto. auto.
+  split; intros; Simpl. unfold v, Val.cmpf. destruct (Val.cmpf_bool c0 (rs x) (rs x0)) as [[]|]; auto.
+* econstructor; split.
+  apply exec_straight_one. eapply transl_cond_float_correct with (v := Val.notbool v); eauto. auto.
+  split; intros; Simpl.
++ (* cmpfs *)
+  destruct (transl_cond_single c0 rd x x0) as [insn normal] eqn:TR.
+  fold (Val.cmpfs c0 (rs x) (rs x0)).
+  set (v := Val.cmpfs c0 (rs x) (rs x0)).
+  destruct normal; inv EQ2.
+* econstructor; split.
+  apply exec_straight_one. eapply transl_cond_single_correct with (v := v); eauto. auto.
+  split; intros; Simpl.
+* econstructor; split.
+  eapply exec_straight_two.
+  eapply transl_cond_single_correct with (v := Val.notbool v); eauto.
+  simpl; reflexivity.
+  auto. auto.
+  split; intros; Simpl. unfold v, Val.cmpfs. destruct (Val.cmpfs_bool c0 (rs x) (rs x0)) as [[]|]; auto.
++ (* notcmpfs *)
+  destruct (transl_cond_single c0 rd x x0) as [insn normal] eqn:TR.
+  rewrite Val.notbool_negb_3. fold (Val.cmpfs c0 (rs x) (rs x0)).
+  set (v := Val.cmpfs c0 (rs x) (rs x0)).
+  destruct normal; inv EQ2.
+* econstructor; split.
+  eapply exec_straight_two.
+  eapply transl_cond_single_correct with (v := v); eauto.
+  simpl; reflexivity.
+  auto. auto.
+  split; intros; Simpl. unfold v, Val.cmpfs. destruct (Val.cmpfs_bool c0 (rs x) (rs x0)) as [[]|]; auto.
+* econstructor; split.
+  apply exec_straight_one. eapply transl_cond_single_correct with (v := Val.notbool v); eauto. auto.
+  split; intros; Simpl.
+*)
+*)
+
+(** Some arithmetic properties. *)
+
+Remark cast32unsigned_from_cast32signed:
+  forall i, Int64.repr (Int.unsigned i) = Int64.zero_ext 32 (Int64.repr (Int.signed i)).
+Proof.
+  intros. apply Int64.same_bits_eq; intros. 
+  rewrite Int64.bits_zero_ext, !Int64.testbit_repr by tauto.
+  rewrite Int.bits_signed by tauto. fold (Int.testbit i i0).
+  change Int.zwordsize with 32.
+  destruct (zlt i0 32). auto. apply Int.bits_above. auto.
+Qed.
+
+Lemma cast32signed_correct:
+  forall (d s: ireg) (k: code) (rs: regset) (m: mem),
+  exists rs': regset,
+    exec_straight ge (cast32signed d s ::g k) rs m k rs' m
+ /\ Val.lessdef (Val.longofint (rs s)) (rs' d)
+ /\ (forall r: preg, r <> PC -> r <> d -> rs' r = rs r).
+Proof.
+  intros. unfold cast32signed. destruct (ireg_eq d s).
+- econstructor; split.
+  + apply exec_straight_one. simpl. eauto with asmgen.
+  + split.
+    * rewrite e. Simpl.
+    * intros. destruct r; Simpl.
+- econstructor; split.
+  + apply exec_straight_one. simpl. eauto with asmgen.
+  + split.
+    * Simpl.
+    * intros. destruct r; Simpl.
+Qed.
+
+(* Translation of arithmetic operations *)
+
+Ltac SimplEval H :=
+  match type of H with
+  | Some _ = None _ => discriminate
+  | Some _ = Some _ => inv H
+  | ?a = Some ?b => let A := fresh in assert (A: Val.maketotal a = b) by (rewrite H; reflexivity)
+end.
+
+Ltac TranslOpSimpl :=
+  econstructor; split;
+  [ apply exec_straight_one; reflexivity
+  | split; [ apply Val.lessdef_same; simpl; Simpl; fail | intros; simpl; Simpl; fail ] ].
+
+Lemma transl_op_correct:
+  forall op args res k (rs: regset) m v c,
+  transl_op op args res k = OK c ->
+  eval_operation ge (rs#SP) op (map rs (map preg_of args)) m = Some v ->
+  exists rs',
+     exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m
+  /\ Val.lessdef v rs'#(preg_of res)
+  /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r.
+Proof.
+  assert (SAME: forall v1 v2, v1 = v2 -> Val.lessdef v2 v1). { intros; subst; auto. }
+Opaque Int.eq.
+  intros until c; intros TR EV.
+  unfold transl_op in TR; destruct op; ArgsInv; simpl in EV; SimplEval EV; try TranslOpSimpl.
+- (* Omove *)
+  destruct (preg_of res), (preg_of m0); inv TR; TranslOpSimpl.
+- (* Oaddrsymbol *)
+  destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)).
++ set (rs1 := (rs#x <- (Genv.symbol_address ge id Ptrofs.zero))).
+  exploit (addptrofs_correct x x ofs (basics_to_code k) rs1 m); eauto with asmgen. 
+  intros (rs2 & A & B & C).
+  exists rs2; split. 
+  apply exec_straight_step with rs1 m; auto.
+  split. replace ofs with (Ptrofs.add Ptrofs.zero ofs) by (apply Ptrofs.add_zero_l). 
+  rewrite Genv.shift_symbol_address.
+  replace (rs1 x) with (Genv.symbol_address ge id Ptrofs.zero) in B by (unfold rs1; Simpl).
+  exact B.
+  intros. rewrite C by eauto with asmgen. unfold rs1; Simpl.  
++ TranslOpSimpl.
+- (* Oaddrstack *)
+  exploit addptrofs_correct. instantiate (1 := GPR12); auto with asmgen. intros (rs' & A & B & C).
+  exists rs'; split; eauto. auto with asmgen.
+- (* Ocast8signed *)
+  econstructor; split.
+  eapply exec_straight_two. simpl;eauto. simpl;eauto.
+  split; intros; simpl; Simpl.
+  assert (A: Int.ltu (Int.repr 24) Int.iwordsize = true) by auto.
+  destruct (rs x0); auto; simpl. rewrite A; simpl. Simpl. unfold Val.shr. rewrite A.
+  apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity.
+- (* Ocast16signed *)
+  econstructor; split.
+  eapply exec_straight_two. simpl;eauto. simpl;eauto.
+  split; intros; Simpl.
+  assert (A: Int.ltu (Int.repr 16) Int.iwordsize = true) by auto.
+  destruct (rs x0); auto; simpl. rewrite A; simpl. Simpl. unfold Val.shr. rewrite A. 
+  apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity.
+- (* Oshrximm *)
+  clear H. exploit Val.shrx_shr_2; eauto. intros E; subst v; clear EV.
+  destruct (Int.eq n Int.zero).
++ econstructor; split. apply exec_straight_one. simpl; eauto.
+  split; intros; Simpl. 
++ change (Int.repr 32) with Int.iwordsize. set (n' := Int.sub Int.iwordsize n).
+  econstructor; split.
+  eapply exec_straight_step. simpl; reflexivity. auto. 
+  eapply exec_straight_step. simpl; reflexivity. auto. 
+  eapply exec_straight_step. simpl; reflexivity. auto. 
+  apply exec_straight_one. simpl; reflexivity. auto. 
+  split; intros; Simpl.
+- (* Ocast32signed *)
+  exploit cast32signed_correct; eauto. intros (rs' & A & B & C).
+  exists rs'; split; eauto. split. apply B.
+  intros. assert (r <> PC). { destruct r; auto; contradict H; discriminate. }
+  apply C; auto.
+- (* longofintu *)
+  econstructor; split.
+  eapply exec_straight_three. simpl; eauto. simpl; eauto. simpl; eauto.
+  split; intros; Simpl. (* unfold Pregmap.set; Simpl. *) destruct (PregEq.eq x0 x0).
+  + destruct (rs x0); auto. simpl. 
+    assert (A: Int.ltu (Int.repr 32) Int64.iwordsize' = true) by auto.
+    rewrite A; simpl. rewrite A. apply Val.lessdef_same. f_equal.
+    rewrite cast32unsigned_from_cast32signed. apply Int64.zero_ext_shru_shl. compute; auto.
+  + contradict n. auto.
+- (* Ocmp *)
+  exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C).
+  exists rs'; split. eexact A. eauto with asmgen.
+(*
+- (* intconst *)
+  exploit loadimm32_correct; eauto. intros (rs' & A & B & C).
+  exists rs'; split; eauto. rewrite B; auto with asmgen.
+- (* longconst *)
+  exploit loadimm64_correct; eauto. intros (rs' & A & B & C).
+  exists rs'; split; eauto. rewrite B; auto with asmgen.
+- (* floatconst *)
+  destruct (Float.eq_dec n Float.zero).
++ subst n. econstructor; split. 
+  apply exec_straight_one. simpl; eauto. auto.
+  split; intros; Simpl. 
++ econstructor; split. 
+  apply exec_straight_one. simpl; eauto. auto.
+  split; intros; Simpl. 
+- (* singleconst *)
+  destruct (Float32.eq_dec n Float32.zero).
++ subst n. econstructor; split. 
+  apply exec_straight_one. simpl; eauto. auto.
+  split; intros; Simpl. 
++ econstructor; split. 
+  apply exec_straight_one. simpl; eauto. auto.
+  split; intros; Simpl. 
+- (* stackoffset *)
+  exploit addptrofs_correct. instantiate (1 := X2); auto with asmgen. intros (rs' & A & B & C).
+  exists rs'; split; eauto. auto with asmgen.
+- (* addimm *)
+  exploit (opimm32_correct Paddw Paddiw Val.add); auto. instantiate (1 := x0); eauto with asmgen.
+  intros (rs' & A & B & C).
+  exists rs'; split; eauto. rewrite B; auto with asmgen. 
+- (* andimm *)
+  exploit (opimm32_correct Pandw Pandiw Val.and); auto. instantiate (1 := x0); eauto with asmgen.
+  intros (rs' & A & B & C).
+  exists rs'; split; eauto. rewrite B; auto with asmgen.
+- (* orimm *)
+  exploit (opimm32_correct Porw Poriw Val.or); auto. instantiate (1 := x0); eauto with asmgen.
+  intros (rs' & A & B & C).
+  exists rs'; split; eauto. rewrite B; auto with asmgen.
+- (* xorimm *)
+  exploit (opimm32_correct Pxorw Pxoriw Val.xor); auto. instantiate (1 := x0); eauto with asmgen.
+  intros (rs' & A & B & C).
+  exists rs'; split; eauto. rewrite B; auto with asmgen.
+
+
+
+- (* addlimm *)
+  exploit (opimm64_correct Paddl Paddil Val.addl); auto. instantiate (1 := x0); eauto with asmgen.
+  intros (rs' & A & B & C).
+  exists rs'; split; eauto. rewrite B; auto with asmgen.
+
+- (* andimm *)
+  exploit (opimm64_correct Pandl Pandil Val.andl); auto. instantiate (1 := x0); eauto with asmgen.
+  intros (rs' & A & B & C).
+  exists rs'; split; eauto. rewrite B; auto with asmgen.
+- (* orimm *)
+  exploit (opimm64_correct Porl Poril Val.orl); auto. instantiate (1 := x0); eauto with asmgen.
+  intros (rs' & A & B & C).
+  exists rs'; split; eauto. rewrite B; auto with asmgen.
+- (* xorimm *)
+  exploit (opimm64_correct Pxorl Pxoril Val.xorl); auto. instantiate (1 := x0); eauto with asmgen.
+  intros (rs' & A & B & C).
+  exists rs'; split; eauto. rewrite B; auto with asmgen.
+- (* shrxlimm *)
+  clear H. exploit Val.shrxl_shrl_2; eauto. intros E; subst v; clear EV.
+  destruct (Int.eq n Int.zero).
++ econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+  split; intros; Simpl. 
++ change (Int.repr 64) with Int64.iwordsize'. set (n' := Int.sub Int64.iwordsize' n).
+  econstructor; split.
+  eapply exec_straight_step. simpl; reflexivity. auto. 
+  eapply exec_straight_step. simpl; reflexivity. auto. 
+  eapply exec_straight_step. simpl; reflexivity. auto. 
+  apply exec_straight_one. simpl; reflexivity. auto. 
+  split; intros; Simpl.
+*)
+Qed.
+
+(** Memory accesses *)
+
+Lemma indexed_memory_access_correct:
+  forall mk_instr base ofs k rs m,
+  base <> GPR31 ->
+  exists base' ofs' rs',
+     exec_straight_opt (indexed_memory_access mk_instr base ofs ::g k) rs m
+                       (mk_instr base' ofs' ::g k) rs' m
+  /\ Val.offset_ptr rs'#base' (eval_offset ge ofs') = Val.offset_ptr rs#base ofs
+  /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r.
+Proof.
+  unfold indexed_memory_access; intros.
+  (* destruct Archi.ptr64 eqn:SF. *)
+  assert (Archi.ptr64 = true) as SF; auto.
+- generalize (make_immed64_sound (Ptrofs.to_int64 ofs)); intros EQ.
+  destruct (make_immed64 (Ptrofs.to_int64 ofs)).
++ econstructor; econstructor; econstructor; split.
+  apply exec_straight_opt_refl. 
+  split; auto. simpl. subst imm. rewrite Ptrofs.of_int64_to_int64 by auto. auto.
+(*
++ econstructor; econstructor; econstructor; split. 
+  constructor. eapply exec_straight_two. 
+  simpl; eauto. simpl; eauto. auto. auto. 
+  split; intros; Simpl. destruct (rs base); auto; simpl. rewrite SF. simpl.
+  rewrite Ptrofs.add_assoc. f_equal. f_equal. 
+  rewrite <- (Ptrofs.of_int64_to_int64 SF ofs). rewrite EQ. 
+  symmetry; auto with ptrofs.
++ econstructor; econstructor; econstructor; split. 
+  constructor. eapply exec_straight_two. 
+  simpl; eauto. simpl; eauto. auto. auto. 
+  split; intros; Simpl. unfold eval_offset. destruct (rs base); auto; simpl. rewrite SF. simpl.
+  rewrite Ptrofs.add_zero. subst imm. rewrite Ptrofs.of_int64_to_int64 by auto. auto.
+(* 32 bits part, irrelevant for us
+- generalize (make_immed32_sound (Ptrofs.to_int ofs)); intros EQ.
+  destruct (make_immed32 (Ptrofs.to_int ofs)).
++ econstructor; econstructor; econstructor; split.
+  apply exec_straight_opt_refl. 
+  split; auto. simpl. subst imm. rewrite Ptrofs.of_int_to_int by auto. auto.
++ econstructor; econstructor; econstructor; split. 
+  constructor. eapply exec_straight_two. 
+  simpl; eauto. simpl; eauto. auto. auto. 
+  split; intros; Simpl. destruct (rs base); auto; simpl. rewrite SF. simpl.
+  rewrite Ptrofs.add_assoc. f_equal. f_equal. 
+  rewrite <- (Ptrofs.of_int_to_int SF ofs). rewrite EQ. 
+  symmetry; auto with ptrofs.
+*)*)
+Qed.
+
+
+Lemma indexed_load_access_correct:
+  forall chunk (mk_instr: ireg -> offset -> basic) rd m,
+  (forall base ofs rs,
+     exec_basic_instr ge (mk_instr base ofs) rs m = exec_load ge chunk rs m rd base ofs) ->
+  forall (base: ireg) ofs k (rs: regset) v,
+  Mem.loadv chunk m (Val.offset_ptr rs#base ofs) = Some v ->
+  base <> GPR31 -> rd <> PC ->
+  exists rs',
+     exec_straight ge (indexed_memory_access mk_instr base ofs ::g k) rs m k rs' m
+  /\ rs'#rd = v
+  /\ forall r, r <> PC -> r <> GPR31 -> r <> rd -> rs'#r = rs#r.
+Proof.
+  intros until m; intros EXEC; intros until v; intros LOAD NOT31 NOTPC.
+  exploit indexed_memory_access_correct; eauto.
+  intros (base' & ofs' & rs' & A & B & C).
+  econstructor; split.
+  eapply exec_straight_opt_right. eexact A. apply exec_straight_one. rewrite EXEC.
+  unfold exec_load. rewrite B, LOAD. eauto. Simpl. 
+  split; intros; Simpl. auto.
+Qed.
+
+Lemma indexed_store_access_correct:
+  forall chunk (mk_instr: ireg -> offset -> basic) r1 m,
+  (forall base ofs rs,
+     exec_basic_instr ge (mk_instr base ofs) rs m = exec_store ge chunk rs m r1 base ofs) ->
+  forall (base: ireg) ofs k (rs: regset) m',
+  Mem.storev chunk m (Val.offset_ptr rs#base ofs) (rs#r1) = Some m' ->
+  base <> GPR31 -> r1 <> GPR31 -> r1 <> PC ->
+  exists rs',
+     exec_straight ge (indexed_memory_access mk_instr base ofs ::g k) rs m k rs' m'
+  /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r.
+Proof.
+  intros until m; intros EXEC; intros until m'; intros STORE NOT31 NOT31' NOTPC.
+  exploit indexed_memory_access_correct. instantiate (1 := base). eauto.
+  intros (base' & ofs' & rs' & A & B & C).
+  econstructor; split.
+  eapply exec_straight_opt_right. eapply A. apply exec_straight_one. rewrite EXEC.
+  unfold exec_store. rewrite B, C, STORE. eauto. eauto. auto.
+  intros; Simpl. rewrite C; auto.
+Qed.
+
+Lemma loadind_correct:
+  forall (base: ireg) ofs ty dst k c (rs: regset) m v,
+  loadind base ofs ty dst k = OK c ->
+  Mem.loadv (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) = Some v ->
+  base <> GPR31 ->
+  exists rs',
+     exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m
+  /\ rs'#(preg_of dst) = v
+  /\ forall r, r <> PC -> r <> GPR31 -> r <> preg_of dst -> rs'#r = rs#r.
+Proof.
+  intros until v; intros TR LOAD NOT31. 
+  assert (A: exists mk_instr,
+                c = indexed_memory_access mk_instr base ofs :: k
+             /\ forall base' ofs' rs',
+                   exec_basic_instr ge (mk_instr base' ofs') rs' m =
+                   exec_load ge (chunk_of_type ty) rs' m (preg_of dst) base' ofs').
+  { unfold loadind in TR.
+    destruct ty, (preg_of dst); inv TR; econstructor; split; eauto. }
+  destruct A as (mk_instr & B & C). subst c. 
+  eapply indexed_load_access_correct; eauto with asmgen. 
+Qed.
+
+Lemma storeind_correct:
+  forall (base: ireg) ofs ty src k c (rs: regset) m m',
+  storeind src base ofs ty k = OK c ->
+  Mem.storev (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) rs#(preg_of src) = Some m' ->
+  base <> GPR31 ->
+  exists rs',
+     exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m'
+  /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r.
+Proof.
+  intros until m'; intros TR STORE NOT31.
+  assert (A: exists mk_instr,
+                c = indexed_memory_access mk_instr base ofs :: k
+             /\ forall base' ofs' rs',
+                   exec_basic_instr ge (mk_instr base' ofs') rs' m =
+                   exec_store ge (chunk_of_type ty) rs' m (preg_of src) base' ofs').
+  { unfold storeind in TR. destruct ty, (preg_of src); inv TR; econstructor; split; eauto. }
+  destruct A as (mk_instr & B & C). subst c. 
+  eapply indexed_store_access_correct; eauto with asmgen. 
+Qed.
+
+Ltac bsimpl := unfold exec_bblock; simpl.
+
+Lemma Pget_correct:
+  forall (dst: gpreg) (src: preg) k (rs: regset) m,
+  src = RA ->
+  exists rs',
+     exec_straight ge (Pget dst src ::g k) rs m k rs' m
+  /\ rs'#dst = rs#src
+  /\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r.
+Proof.
+  intros. econstructor; econstructor; econstructor.
+- rewrite H. bsimpl. auto.
+- Simpl.
+- intros. Simpl.
+Qed.
+
+Lemma Pset_correct:
+  forall (dst: preg) (src: gpreg) k (rs: regset) m,
+  dst = RA ->
+  exists rs',
+     exec_straight ge (Pset dst src ::g k) rs m k rs' m
+  /\ rs'#dst = rs#src
+  /\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r.
+Proof.
+  intros. econstructor; econstructor; econstructor; simpl.
+  rewrite H. auto.
+  Simpl.
+  Simpl.
+  intros. rewrite H. Simpl.
+Qed.
+
+Lemma loadind_ptr_correct:
+  forall (base: ireg) ofs (dst: ireg) k (rs: regset) m v,
+  Mem.loadv Mptr m (Val.offset_ptr rs#base ofs) = Some v ->
+  base <> GPR31 ->
+  exists rs',
+     exec_straight ge (loadind_ptr base ofs dst ::g k) rs m k rs' m
+  /\ rs'#dst = v
+  /\ forall r, r <> PC -> r <> GPR31 -> r <> dst -> rs'#r = rs#r.
+Proof.
+  intros. eapply indexed_load_access_correct; eauto with asmgen.
+  intros. unfold Mptr. assert (Archi.ptr64 = true). auto. rewrite H1. auto.
+Qed.
+
+Lemma storeind_ptr_correct:
+  forall (base: ireg) ofs (src: ireg) k (rs: regset) m m',
+  Mem.storev Mptr m (Val.offset_ptr rs#base ofs) rs#src = Some m' ->
+  base <> GPR31 -> src <> GPR31 ->
+  exists rs',
+     exec_straight ge (storeind_ptr src base ofs ::g k) rs m k rs' m'
+  /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r.
+Proof.
+  intros. eapply indexed_store_access_correct with (r1 := src); eauto with asmgen.
+  intros. unfold Mptr. assert (Archi.ptr64 = true); auto.
+Qed.
+
+Lemma transl_memory_access_correct:
+  forall mk_instr addr args k c (rs: regset) m v,
+  transl_memory_access mk_instr addr args k = OK c ->
+  eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v ->
+  exists base ofs rs',
+     exec_straight_opt (basics_to_code c) rs m (mk_instr base ofs ::g (basics_to_code k)) rs' m
+  /\ Val.offset_ptr rs'#base (eval_offset ge ofs) = v
+  /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r.
+Proof.
+  intros until v; intros TR EV. 
+  unfold transl_memory_access in TR; destruct addr; ArgsInv.
+- (* indexed *)
+  inv EV. apply indexed_memory_access_correct; eauto with asmgen.
+- (* global *)
+  simpl in EV. inv EV. inv TR.  econstructor; econstructor; econstructor; split.
+  constructor. apply exec_straight_one. simpl; eauto. auto. 
+  split; intros; Simpl. unfold eval_offset.
+  assert (Val.lessdef (Val.offset_ptr (Genv.symbol_address ge i i0) Ptrofs.zero) (Genv.symbol_address ge i i0)).
+  { apply Val.offset_ptr_zero. }
+  remember (Genv.symbol_address ge i i0) as symbol.
+  destruct symbol; auto.
+  + contradict Heqsymbol; unfold Genv.symbol_address;
+    destruct (Genv.find_symbol ge i); discriminate.
+  + contradict Heqsymbol; unfold Genv.symbol_address;
+    destruct (Genv.find_symbol ge i); discriminate.
+  + contradict Heqsymbol; unfold Genv.symbol_address;
+    destruct (Genv.find_symbol ge i); discriminate.
+  + contradict Heqsymbol; unfold Genv.symbol_address;
+    destruct (Genv.find_symbol ge i); discriminate.
+  + simpl. rewrite Ptrofs.add_zero; auto.
+- (* stack *)
+  inv TR. inv EV. apply indexed_memory_access_correct; eauto with asmgen.
+Qed.
+
+Lemma transl_load_access_correct:
+  forall chunk (mk_instr: ireg -> offset -> basic) addr args k c rd (rs: regset) m v v',
+  (forall base ofs rs,
+     exec_basic_instr ge (mk_instr base ofs) rs m = exec_load ge chunk rs m rd base ofs) ->
+  transl_memory_access mk_instr addr args k = OK c ->
+  eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v ->
+  Mem.loadv chunk m v = Some v' ->
+  rd <> PC ->
+  exists rs',
+     exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m
+  /\ rs'#rd = v'
+  /\ forall r, r <> PC -> r <> GPR31 -> r <> rd -> rs'#r = rs#r.
+Proof.
+  intros until v'; intros INSTR TR EV LOAD NOTPC. 
+  exploit transl_memory_access_correct; eauto.
+  intros (base & ofs & rs' & A & B & C).
+  econstructor; split.
+  eapply exec_straight_opt_right. eexact A. apply exec_straight_one. 
+  rewrite INSTR. unfold exec_load. rewrite B, LOAD. reflexivity. Simpl. 
+  split; intros; Simpl. auto.
+Qed.
+
+Lemma transl_store_access_correct:
+  forall chunk (mk_instr: ireg -> offset -> basic) addr args k c r1 (rs: regset) m v m',
+  (forall base ofs rs,
+     exec_basic_instr ge (mk_instr base ofs) rs m = exec_store ge chunk rs m r1 base ofs) ->
+  transl_memory_access mk_instr addr args k = OK c ->
+  eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v ->
+  Mem.storev chunk m v rs#r1 = Some m' ->
+  r1 <> PC -> r1 <> GPR31 ->
+  exists rs',
+     exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m'
+  /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r.
+Proof.
+  intros until m'; intros INSTR TR EV STORE NOTPC NOT31. 
+  exploit transl_memory_access_correct; eauto.
+  intros (base & ofs & rs' & A & B & C).
+  econstructor; split.
+  eapply exec_straight_opt_right. eexact A. apply exec_straight_one. 
+  rewrite INSTR. unfold exec_store. rewrite B, C, STORE by auto. reflexivity. auto.
+Qed.
+
+Lemma transl_load_correct:
+  forall chunk addr args dst k c (rs: regset) m a v,
+  transl_load chunk addr args dst k = OK c ->
+  eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a ->
+  Mem.loadv chunk m a = Some v ->
+  exists rs',
+     exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m
+  /\ rs'#(preg_of dst) = v
+  /\ forall r, r <> PC -> r <> GPR31 -> r <> preg_of dst -> rs'#r = rs#r.
+Proof.
+  intros until v; intros TR EV LOAD. 
+  assert (A: exists mk_instr,
+      transl_memory_access mk_instr addr args k = OK c
+   /\ forall base ofs rs,
+        exec_basic_instr ge (mk_instr base ofs) rs m = exec_load ge chunk rs m (preg_of dst) base ofs).
+  { unfold transl_load in TR; destruct chunk; ArgsInv; econstructor; (split; [eassumption|auto]). }
+  destruct A as (mk_instr & B & C).
+  eapply transl_load_access_correct; eauto with asmgen.
+Qed.
+
+Lemma transl_store_correct:
+  forall chunk addr args src k c (rs: regset) m a m',
+  transl_store chunk addr args src k = OK c ->
+  eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a ->
+  Mem.storev chunk m a rs#(preg_of src) = Some m' ->
+  exists rs',
+     exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m'
+  /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r.
+Proof.
+  intros until m'; intros TR EV STORE. 
+  assert (A: exists mk_instr chunk',
+      transl_memory_access mk_instr addr args k = OK c
+   /\ (forall base ofs rs,
+        exec_basic_instr ge (mk_instr base ofs) rs m = exec_store ge chunk' rs m (preg_of src) base ofs)
+   /\ Mem.storev chunk m a rs#(preg_of src) = Mem.storev chunk' m a rs#(preg_of src)).
+  { unfold transl_store in TR; destruct chunk; ArgsInv;
+    (econstructor; econstructor; split; [eassumption | split; [ intros; simpl; reflexivity | auto]]).
+    destruct a; auto. apply Mem.store_signed_unsigned_8. 
+    destruct a; auto. apply Mem.store_signed_unsigned_16. 
+  }
+  destruct A as (mk_instr & chunk' & B & C & D).
+  rewrite D in STORE; clear D. 
+  eapply transl_store_access_correct; eauto with asmgen.
+Qed.
+
+Lemma make_epilogue_correct:
+  forall ge0 f m stk soff cs m' ms rs k tm,
+  Mach.load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp cs) ->
+  Mach.load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra cs) ->
+  Mem.free m stk 0 f.(fn_stacksize) = Some m' ->
+  agree ms (Vptr stk soff) rs ->
+  Mem.extends m tm ->
+  match_stack ge0 cs ->
+  exists rs', exists tm',
+     exec_straight ge (make_epilogue f k) rs tm k rs' tm'
+  /\ agree ms (parent_sp cs) rs'
+  /\ Mem.extends m' tm'
+  /\ rs'#RA = parent_ra cs
+  /\ rs'#SP = parent_sp cs
+  /\ (forall r, r <> PC -> r <> RA -> r <> SP -> r <> GPR31 -> r <> GPR8 -> rs'#r = rs#r).
+Proof.
+  intros until tm; intros LP LRA FREE AG MEXT MCS.
+  exploit Mem.loadv_extends. eauto. eexact LP. auto. simpl. intros (parent' & LP' & LDP').
+  exploit Mem.loadv_extends. eauto. eexact LRA. auto. simpl. intros (ra' & LRA' & LDRA').
+  exploit lessdef_parent_sp; eauto. intros EQ; subst parent'; clear LDP'.
+  exploit lessdef_parent_ra; eauto. intros EQ; subst ra'; clear LDRA'.
+  exploit Mem.free_parallel_extends; eauto. intros (tm' & FREE' & MEXT').
+  unfold make_epilogue. 
+  rewrite chunk_of_Tptr in *.
+
+  exploit ((loadind_ptr_correct SP (fn_retaddr_ofs f) GPR8 (Pset RA GPR8 ::g Pfreeframe (fn_stacksize f) (fn_link_ofs f) ::g k))
+            rs tm).
+  - rewrite <- (sp_val _ _ rs AG). simpl. eexact LRA'.
+  - congruence.
+  - intros (rs1 & A1 & B1 & C1).
+    assert (agree ms (Vptr stk soff) rs1) as AG1.
+    + destruct AG.
+      apply mkagree; auto.
+      rewrite C1; discriminate || auto.
+      intro. rewrite C1; auto; destruct r; simpl; try discriminate.
+    + exploit (Pset_correct RA GPR8 (Pfreeframe (fn_stacksize f) (fn_link_ofs f) ::g k) rs1 tm). auto.
+      intros (rs2 & A2 & B2 & C2).
+      econstructor; econstructor; split.
+      * eapply exec_straight_trans.
+        { eexact A1. }
+        { eapply exec_straight_trans.
+          { eapply A2. }
+          { apply exec_straight_one. simpl.
+            rewrite (C2 GPR12) by auto with asmgen. rewrite <- (sp_val _ _ rs1 AG1). simpl; rewrite LP'.
+            rewrite FREE'; eauto. (* auto. *) } }
+      * split. (* apply agree_nextinstr.  *)apply agree_set_other; auto with asmgen. 
+    apply agree_change_sp with (Vptr stk soff).
+    apply agree_exten with rs; auto. intros; rewrite C2; auto with asmgen.
+    eapply parent_sp_def; eauto.
+  split. auto.
+  split. Simpl. rewrite B2. auto.
+  split. Simpl. 
+  intros. Simpl.
+  rewrite C2; auto.
+Qed.
+
+End CONSTRUCTORS.
+
+ 
diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml
index 951a7511..13869268 100644
--- a/mppa_k1c/Asmexpand.ml
+++ b/mppa_k1c/Asmexpand.ml
@@ -20,6 +20,7 @@
    of the RISC-V assembly code. *)
 
 open Asm
+open Asmgen
 open Asmexpandaux
 open AST
 open Camlcoq
@@ -47,9 +48,9 @@ let align n a = (n + a - 1) land (-a)
   List.iter emit (Asmgen.loadimm32 dst n [])
 *)
 let expand_addptrofs dst src n =
-  List.iter emit (Asmgen.addptrofs dst src n [])
+  List.iter emit (addptrofs dst src n :: [])
 let expand_storeind_ptr src base ofs =
-  List.iter emit (Asmgen.storeind_ptr src base ofs [])
+  List.iter emit (storeind_ptr src base ofs :: [])
 
 (* Built-ins.  They come in two flavors:
    - annotation statements: take their arguments in registers or stack
@@ -61,7 +62,7 @@ let expand_storeind_ptr src base ofs =
 (* Fix-up code around calls to variadic functions.  Floating-point arguments
    residing in FP registers need to be moved to integer registers. *)
 
-let int_param_regs   = [| GPR0; GPR1; GPR2; GPR3; GPR4; GPR5; GPR6; GPR7 |]
+let int_param_regs   = let open Asmblock in [| GPR0; GPR1; GPR2; GPR3; GPR4; GPR5; GPR6; GPR7 |]
 (* let float_param_regs = [| F10; F11; F12; F13; F14; F15; F16; F17 |] *)
 let float_param_regs = [| |]
 
@@ -330,7 +331,7 @@ let rec args_size sz = function
 let arguments_size sg =
   args_size 0 sg.sig_args
 
-let save_arguments first_reg base_ofs =
+let save_arguments first_reg base_ofs = let open Asmblock in
   for i = first_reg to 7 do
     expand_storeind_ptr
       int_param_regs.(i)
@@ -412,82 +413,18 @@ let expand_bswap64 d s = assert false
 
 (* Handling of compiler-inlined builtins *)
 
-let expand_builtin_inline name args res =
+let expand_builtin_inline name args res = let open Asmblock in
   match name, args, res with
   (* Synchronization *)
   | "__builtin_membar", [], _ ->
      ()
-  (* BCU *)
-  | "__builtin_k1_await", [], BR(IR _) -> emit (PExpand (Pawait))
-  | "__builtin_k1_barrier", [], BR(IR _) -> emit (PExpand (Pbarrier))
-  | "__builtin_k1_doze", [], BR(IR _) -> emit (PExpand (Pdoze))
-  | "__builtin_k1_wfxl", [BA(IR a1); BA(IR a2)], BR(IR _) -> emit (PExpand (Pwfxl(a1, a2)))
-  | "__builtin_k1_wfxm", [BA(IR a1); BA(IR a2)], BR(IR _) -> emit (PExpand (Pwfxm(a1, a2)))
-  | "__builtin_k1_invaldtlb", [], BR(IR _) -> emit (PExpand (Pinvaldtlb))
-  | "__builtin_k1_invalitlb", [], BR(IR _) -> emit (PExpand (Pinvalitlb))
-  | "__builtin_k1_probetlb", [], BR(IR _) -> emit (PExpand (Pprobetlb))
-  | "__builtin_k1_readtlb", [], BR(IR _) -> emit (PExpand (Preadtlb))
-  | "__builtin_k1_sleep", [], BR(IR _) -> emit (PExpand (Psleep))
-  | "__builtin_k1_stop", [], BR(IR _) -> emit (PExpand (Pstop))
-  | "__builtin_k1_syncgroup", [BA(IR a1)], BR(IR _) -> emit (PExpand (Psyncgroup(a1)))
-  | "__builtin_k1_tlbwrite", [], BR(IR _) -> emit (PExpand (Ptlbwrite))
-
-  (* LSU *)
-  | "__builtin_k1_afda", [BA(IR a1); BA(IR a2)], BR(IR r) -> emit (PExpand (Pafda(r, a1, a2)))
-  | "__builtin_k1_aldc", [BA(IR a1)], BR(IR r) -> emit (PExpand (Paldc(r, a1)))
-  | "__builtin_k1_dinval", [], BR(IR _) -> emit (PExpand (Pdinval))
-  | "__builtin_k1_dinvall", [BA(IR a1)], BR(IR _) -> emit (PExpand (Pdinvall(a1)))
-  | "__builtin_k1_dtouchl", [BA(IR a1)], BR(IR _) -> emit (PExpand (Pdtouchl(a1)))
-  | "__builtin_k1_dzerol", [BA(IR a1)], BR(IR _) -> emit (PExpand (Pdzerol(a1)))
-  | "__builtin_k1_fence", [], BR(IR _) -> emit (PExpand (Pfence))
-  | "__builtin_k1_iinval", [], BR(IR _) -> emit (PExpand (Piinval))
-  | "__builtin_k1_iinvals", [BA(IR a1)], BR(IR _) -> emit (PExpand (Piinvals(a1)))
-  | "__builtin_k1_itouchl", [BA(IR a1)], BR(IR _) -> emit (PExpand (Pitouchl(a1)))
-  | "__builtin_k1_lbsu", [BA(IR a1)], BR(IR r) -> emit (PExpand (Plbsu(r, a1)))
-  | "__builtin_k1_lbzu", [BA(IR a1)], BR(IR r) -> emit (PExpand (Plbzu(r, a1)))
-  | "__builtin_k1_ldu", [BA(IR a1)], BR(IR r) -> emit (PExpand (Pldu(r, a1)))
-  | "__builtin_k1_lhsu", [BA(IR a1)], BR(IR r) -> emit (PExpand (Plhsu(r, a1)))
-  | "__builtin_k1_lhzu", [BA(IR a1)], BR(IR r) -> emit (PExpand (Plhzu(r, a1)))
-  | "__builtin_k1_lwzu", [BA(IR a1)], BR(IR r) -> emit (PExpand (Plwzu(r, a1)))
-
-  (* ALU *)
-  | "__builtin_k1_addhp", [BA(IR a1); BA(IR a2)], BR(IR r) -> emit (PExpand (Paddhp(r, a1, a2)))
-  | "__builtin_k1_adds", [BA(IR a1); BA(IR a2)], BR(IR r) -> emit (PExpand (Padds(r, a1, a2)))
-  | "__builtin_k1_bwlu", [BA(IR a1); BA(IR a2); BA(IR a3); BA(IR a4); BA(IR a5)], BR(IR r) -> 
-          emit (PExpand (Pbwlu(r, a1, a2, a3, a4, a5)))
-  | "__builtin_k1_bwluhp", [BA(IR a1); BA(IR a2); BA(IR a3);], BR(IR r) -> 
-          emit (PExpand (Pbwluhp(r, a1, a2, a3)))
-  | "__builtin_k1_bwluwp", [BA(IR a1); BA(IR a2); BA(IR a3);], BR(IR r) -> 
-          emit (PExpand (Pbwluwp(r, a1, a2, a3)))
-  | "__builtin_k1_cbs", [BA(IR a1)], BR(IR r) -> emit (PExpand (Pcbs(r, a1)))
-  | "__builtin_k1_cbsdl", [BA(IR a1)], BR(IR r) -> emit (PExpand (Pcbsdl(r, a1)))
-  | "__builtin_k1_clz", [BA(IR a1)], BR(IR r) -> emit (PExpand (Pclz(r, a1)))
-  | "__builtin_k1_clzw", [BA(IR a1)], BR(IR r) -> emit (PExpand (Pclzw(r, a1)))
-  | "__builtin_k1_clzd", [BA(IR a1)], BR(IR r) -> emit (PExpand (Pclzd(r, a1)))
-  | "__builtin_k1_clzdl", [BA(IR a1)], BR(IR r) -> emit (PExpand (Pclzdl(r, a1)))
-  | "__builtin_k1_cmove", [BA(IR a1); BA(IR a2); BA(IR a3);], BR(IR r) -> 
-          emit (PExpand (Pcmove(r, a1, a2, a3)))
-  | "__builtin_k1_ctz", [BA(IR a1)], BR(IR r) -> emit (PExpand (Pctz(r, a1)))
-  | "__builtin_k1_ctzw", [BA(IR a1)], BR(IR r) -> emit (PExpand (Pctzw(r, a1)))
-  | "__builtin_k1_ctzd", [BA(IR a1)], BR(IR r) -> emit (PExpand (Pctzd(r, a1)))
-  | "__builtin_k1_ctzdl", [BA(IR a1)], BR(IR r) -> emit (PExpand (Pctzdl(r, a1)))
-  | "__builtin_k1_extfz", [BA(IR a1); BA(IR a2); BA(IR a3);], BR(IR r) -> 
-          emit (PExpand (Pextfz(r, a1, a2, a3)))
-  | "__builtin_k1_landhp", [BA(IR a1); BA(IR a2); BA(IR a3);], BR(IR r) -> 
-          emit (PExpand (Plandhp(r, a1, a2, a3)))
-  | "__builtin_k1_sat", [BA(IR a1); BA(IR a2)], BR(IR r) -> emit (PExpand (Psat(r, a1, a2)))
-  | "__builtin_k1_satd", [BA(IR a1); BA(IR a2)], BR(IR r) -> emit (PExpand (Psatd(r, a1, a2)))
-  | "__builtin_k1_sbfhp", [BA(IR a1); BA(IR a2)], BR(IR r) -> emit (PExpand (Psbfhp(r, a1, a2)))
-  | "__builtin_k1_sbmm8", [BA(IR a1); BA(IR a2)], BR(IR r) -> emit (PExpand (Psbmm8(r, a1, a2)))
-  | "__builtin_k1_sbmmt8", [BA(IR a1); BA(IR a2)], BR(IR r) -> emit (PExpand (Psbmmt8(r, a1, a2)))
-  | "__builtin_k1_sllhps", [BA(IR a1); BA(IR a2)], BR(IR r) -> emit (PExpand (Psllhps(r, a1, a2)))
-  | "__builtin_k1_srahps", [BA(IR a1); BA(IR a2)], BR(IR r) -> emit (PExpand (Psrahps(r, a1, a2)))
-  | "__builtin_k1_stsu", [BA(IR a1); BA(IR a2)], BR(IR r) -> emit (PExpand (Pstsu(r, a1, a2)))
-  | "__builtin_k1_stsud", [BA(IR a1); BA(IR a2)], BR(IR r) -> emit (PExpand (Pstsud(r, a1, a2)))
-
   (* Vararg stuff *)
   | "__builtin_va_start", [BA(IR a)], _ ->
      expand_builtin_va_start a
+  | "__builtin_clzll", [BA(IR a)], BR(IR res) ->
+     emit (Pclzll(res, a))
+  | "__builtin_k1_stsud", [BA(IR a1); BA(IR a2)], BR(IR res) ->
+     emit (Pstsud(res, a1, a2))
   (* Byte swaps *)
 (*| "__builtin_bswap16", [BA(IR a1)], BR(IR res) ->
      expand_bswap16 res a1
@@ -502,32 +439,32 @@ let expand_builtin_inline name args res =
 
 let expand_instruction instr =
   match instr with
-  | PExpand Pallocframe (sz, ofs) ->
+  | Pallocframe (sz, ofs) ->
       let sg = get_current_function_sig() in
-      emit (PArith (PArithRR (Pmv, GPR10, GPR12)));
+      emit (Pmv (Asmblock.GPR10, Asmblock.GPR12));
       if sg.sig_cc.cc_vararg then begin
         let n = arguments_size sg in
         let extra_sz = if n >= 8 then 0 else align 16 ((8 - n) * wordsize) in
         let full_sz = Z.add sz (Z.of_uint extra_sz) in
-        expand_addptrofs GPR12 GPR12 (Ptrofs.repr (Z.neg full_sz));
-        expand_storeind_ptr GPR10 GPR12 ofs;
+        expand_addptrofs Asmblock.GPR12 Asmblock.GPR12 (Ptrofs.repr (Z.neg full_sz));
+        expand_storeind_ptr Asmblock.GPR10 Asmblock.GPR12 ofs;
         let va_ofs =
           Z.add full_sz (Z.of_sint ((n - 8) * wordsize)) in
         vararg_start_ofs := Some va_ofs;
         save_arguments n va_ofs
       end else begin
-        expand_addptrofs GPR12 GPR12 (Ptrofs.repr (Z.neg sz));
-        expand_storeind_ptr GPR10 GPR12 ofs;
+        expand_addptrofs Asmblock.GPR12 Asmblock.GPR12 (Ptrofs.repr (Z.neg sz));
+        expand_storeind_ptr Asmblock.GPR10 Asmblock.GPR12 ofs;
         vararg_start_ofs := None
       end
-  | PExpand Pfreeframe (sz, ofs) ->
+  | Pfreeframe (sz, ofs) ->
      let sg = get_current_function_sig() in
      let extra_sz =
       if sg.sig_cc.cc_vararg then begin
         let n = arguments_size sg in
         if n >= 8 then 0 else align 16 ((8 - n) * wordsize)
       end else 0 in
-     expand_addptrofs GPR12 GPR12 (Ptrofs.repr (Z.add sz (Z.of_uint extra_sz)))
+     expand_addptrofs Asmblock.GPR12 Asmblock.GPR12 (Ptrofs.repr (Z.add sz (Z.of_uint extra_sz)))
 
 (*| Pseqw(rd, rs1, rs2) ->
       (* emulate based on the fact that x == 0 iff x <u 1 (unsigned cmp) *)
@@ -557,10 +494,10 @@ let expand_instruction instr =
       end else begin
         emit (Pxorl(rd, rs1, rs2)); emit (Psltul(rd, X0, X rd))
       end
-*)| PArith PArithRR (Pcvtl2w,rd, rs) ->
+*)| Pcvtl2w (rd, rs) ->
       assert Archi.ptr64;
-      emit (PArith (PArithRRI32 (Paddiw,rd, rs, Int.zero)))  (* 32-bit sign extension *)
-  | PArith PArithR r -> (* Pcvtw2l *)
+      emit (Paddiw (rd, rs, Int.zero))  (* 32-bit sign extension *)
+  | Pcvtw2l (r) -> (* Pcvtw2l *)
       assert Archi.ptr64
       (* no-operation because the 32-bit integer was kept sign extended already *)
       (* FIXME - is it really the case on the MPPA ? *)
@@ -574,7 +511,7 @@ let expand_instruction instr =
   | Pj_s(symb, sg) ->
       fixup_call sg; emit instr
 
-*)| PExpand Pbuiltin (ef,args,res) ->
+*)| Pbuiltin (ef,args,res) ->
      begin match ef with
      | EF_builtin (name,sg) ->
         expand_builtin_inline (camlstring_of_coqstring name) args res
@@ -596,7 +533,7 @@ let expand_instruction instr =
 
 (* NOTE: Dwarf register maps for RV32G are not yet specified
    officially.  This is just a placeholder.  *)
-let int_reg_to_dwarf = function
+let int_reg_to_dwarf = let open Asmblock in function
    | GPR0  -> 1   | GPR1  -> 2   | GPR2  -> 3   | GPR3  -> 4   | GPR4  -> 5
    | GPR5  -> 6   | GPR6  -> 7   | GPR7  -> 8   | GPR8  -> 9   | GPR9  -> 10
    | GPR10 -> 11  | GPR11 -> 12  | GPR12 -> 13  | GPR13 -> 14  | GPR14 -> 15
@@ -611,7 +548,7 @@ let int_reg_to_dwarf = function
    | GPR55 -> 56  | GPR56 -> 57  | GPR57 -> 58  | GPR58 -> 59  | GPR59 -> 60
    | GPR60 -> 61  | GPR61 -> 62  | GPR62 -> 63  | GPR63 -> 64
 
-let preg_to_dwarf = function
+let preg_to_dwarf = let open Asmblock in function
    | IR r -> int_reg_to_dwarf r
    | FR r -> int_reg_to_dwarf r
    | RA   -> 65 (* FIXME - No idea what is $ra DWARF number in k1-gdb *)
diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v
index 6b6531c3..9b9e6272 100644
--- a/mppa_k1c/Asmgen.v
+++ b/mppa_k1c/Asmgen.v
@@ -15,826 +15,29 @@
 (*                                                                     *)
 (* *********************************************************************)
 
-(** Translation from Mach to RISC-V assembly language *)
+Require Import Integers.
+Require Import Mach Asm Asmblock Asmblockgen Machblockgen.
+Require Import Errors.
 
-Require Archi.
-Require Import Coqlib Errors.
-Require Import AST Integers Floats Memdata.
-Require Import Op Locations Mach Asm.
-
-Local Open Scope string_scope.
 Local Open Scope error_monad_scope.
 
-(** The code generation functions take advantage of several
-  characteristics of the [Mach] code generated by earlier passes of the
-  compiler, mostly that argument and result registers are of the correct
-  types.  These properties are true by construction, but it's easier to
-  recheck them during code generation and fail if they do not hold. *)
-
-(** 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 IR mr => OK mr | _ => Error(msg "Asmgen.freg_of") end.
-
-(*
-(** Decomposition of 32-bit integer constants.  They are split into either
-  small signed immediates that fit in 12-bits, or, if they do not fit,
-  into a (20-bit hi, 12-bit lo) pair where lo is sign-extended. *)
-
-*)
-Inductive immed32 : Type :=
-  | Imm32_single (imm: int).
-
-Definition make_immed32 (val: int) := Imm32_single val.
-
-(** Likewise, for 64-bit integer constants. *)
-Inductive immed64 : Type :=
-  | Imm64_single (imm: int64)
-.
-
-(* For now, let's suppose all instructions of K1c can handle 64-bits immediate *)
-Definition make_immed64 (val: int64) := Imm64_single val.
-
-Notation "a ::i b" := (cons (A:=instruction) a b) (at level 49, right associativity).
-
-(** Smart constructors for arithmetic operations involving
-  a 32-bit or 64-bit integer constant.  Depending on whether the
-  constant fits in 12 bits or not, one or several instructions
-  are generated as required to perform the operation
-  and prepended to the given instruction sequence [k]. *)
-
-Definition loadimm32 (r: ireg) (n: int) (k: code) :=
-  match make_immed32 n with
-  | Imm32_single imm => Pmake r imm ::i k
-  end.
-
-Definition opimm32 (op: arith_name_rrr)
-                   (opimm: arith_name_rri32)
-                   (rd rs: ireg) (n: int) (k: code) :=
-  match make_immed32 n with
-  | Imm32_single imm => opimm rd rs imm ::i k
-  end.
-
-Definition addimm32 := opimm32 Paddw Paddiw.
-Definition andimm32 := opimm32 Pandw Pandiw.
-Definition orimm32  := opimm32 Porw Poriw.
-Definition xorimm32 := opimm32 Pxorw Pxoriw.
-(*
-Definition sltimm32 := opimm32 Psltw Psltiw.
-Definition sltuimm32 := opimm32 Psltuw Psltiuw.
-*)
-
-Definition loadimm64 (r: ireg) (n: int64) (k: code) :=
-  match make_immed64 n with
-  | Imm64_single imm => Pmakel r imm ::i k
-  end.
-
-Definition opimm64 (op: arith_name_rrr)
-                   (opimm: arith_name_rri64)
-                   (rd rs: ireg) (n: int64) (k: code) :=
-  match make_immed64 n with
-  | Imm64_single imm => opimm rd rs imm ::i k
-end.
-
-Definition addimm64 := opimm64 Paddl Paddil.
-Definition orimm64  := opimm64 Porl  Poril.
-Definition andimm64 := opimm64 Pandl Pandil.
-Definition xorimm64 := opimm64 Pxorl  Pxoril.
-
-(*
-Definition sltimm64 := opimm64 Psltl Psltil.
-Definition sltuimm64 := opimm64 Psltul Psltiul.
-*)
-
-Definition cast32signed (rd rs: ireg) (k: code) := 
-  if (ireg_eq rd rs)
-    then Pcvtw2l rd ::i k
-    else Pmvw2l rd rs ::i k
-  .
-
-Definition addptrofs (rd rs: ireg) (n: ptrofs) (k: code) :=
-  if Ptrofs.eq_dec n Ptrofs.zero then
-    Pmv rd rs ::i k
-  else
-    addimm64 rd rs (Ptrofs.to_int64 n) k.
-
-(** Translation of conditional branches. *)
-
-Definition transl_comp
-    (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction :=
-  Pcompw (itest_for_cmp c s) RTMP r1 r2 ::i Pcb BTwnez RTMP lbl ::i k.
-
-Definition transl_compl
-    (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction :=
-  Pcompl (itest_for_cmp c s) RTMP r1 r2 ::i Pcb BTwnez RTMP lbl ::i k.
-
-Definition select_comp (n: int) (c: comparison) : option comparison :=
-  if Int.eq n Int.zero then
-    match c with
-    | Ceq => Some Ceq
-    | Cne => Some Cne
-    | _   => None
-    end
-  else
-    None
-  .
-
-Definition transl_opt_compuimm
-    (n: int) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction :=
-  match select_comp n c with
-  | Some Ceq => Pcbu BTweqz r1 lbl ::i k
-  | Some Cne => Pcbu BTwnez r1 lbl ::i k
-  | Some _   => nil (* Never happens *)
-  | None     => loadimm32 RTMP n (transl_comp c Unsigned r1 RTMP lbl k)
-  end
-  .
-
-Definition select_compl (n: int64) (c: comparison) : option comparison :=
-  if Int64.eq n Int64.zero then
-    match c with
-    | Ceq => Some Ceq
-    | Cne => Some Cne
-    | _   => None
-    end
-  else
-    None
-  .
-
-Definition transl_opt_compluimm
-    (n: int64) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction :=
-  match select_compl n c with
-  | Some Ceq => Pcbu BTdeqz r1 lbl ::i k
-  | Some Cne => Pcbu BTdnez r1 lbl ::i k
-  | Some _   => nil (* Never happens *)
-  | None     => loadimm64 RTMP n (transl_compl c Unsigned r1 RTMP lbl k)
-  end
-  .
-
-Definition transl_cbranch
-    (cond: condition) (args: list mreg) (lbl: label) (k: code) : res (list instruction ) :=
-  match cond, args with
-  | Ccompuimm c n, a1 :: nil =>
-      do r1 <- ireg_of a1;
-      OK (transl_opt_compuimm n c r1 lbl k)
-  | Ccomp c, a1 :: a2 :: nil =>
-      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
-      OK (transl_comp c Signed r1 r2 lbl k)
-  | Ccompu c, a1 :: a2 :: nil =>
-      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
-      OK (transl_comp c Unsigned r1 r2 lbl k)
-  | Ccompimm c n, a1 :: nil =>
-      do r1 <- ireg_of a1;
-      OK (if Int.eq n Int.zero then
-            Pcb (btest_for_cmpswz c) r1 lbl ::i k
-          else
-            loadimm32 RTMP n (transl_comp c Signed r1 RTMP lbl k)
-         )
-  | Ccompluimm c n, a1 :: nil =>
-      do r1 <- ireg_of a1;
-      OK (transl_opt_compluimm n c r1 lbl k)
-  | Ccompl c, a1 :: a2 :: nil =>
-      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
-      OK (transl_compl c Signed r1 r2 lbl k)
-  | Ccomplu c, a1 :: a2 :: nil =>
-      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
-      OK (transl_compl c Unsigned r1 r2 lbl k)
-  | Ccomplimm c n, a1 :: nil =>
-      do r1 <- ireg_of a1;
-      OK (if Int64.eq n Int64.zero then
-            Pcb (btest_for_cmpsdz c) r1 lbl ::i k
-          else
-            loadimm64 RTMP n (transl_compl c Signed r1 RTMP lbl k)
-         )
-(*| Ccompf c, f1 :: f2 :: nil =>
-      do r1 <- freg_of f1; do r2 <- freg_of f2;
-      let (insn, normal) := transl_cond_float c rd r1 r2 in
-      OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k)
-  | Cnotcompf c, f1 :: f2 :: nil =>
-      do r1 <- freg_of f1; do r2 <- freg_of f2;
-      let (insn, normal) := transl_cond_float c rd r1 r2 in
-      OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k)
-  | Ccompfs c, f1 :: f2 :: nil =>
-      do r1 <- freg_of f1; do r2 <- freg_of f2;
-      let (insn, normal) := transl_cond_single c rd r1 r2 in
-      OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k)
-  | Cnotcompfs c, f1 :: f2 :: nil =>
-      do r1 <- freg_of f1; do r2 <- freg_of f2;
-      let (insn, normal) := transl_cond_single c rd r1 r2 in
-      OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k)
-*)| _, _ =>
-      Error(msg "Asmgen.transl_cbranch")
-  end.
-
-(** Translation of a condition operator.  The generated code sets the
-  [rd] target register to 0 or 1 depending on the truth value of the
-  condition. *)
-
-Definition transl_cond_int32s (cmp: comparison) (rd r1 r2: ireg) (k: code) :=
-  Pcompw (itest_for_cmp cmp Signed) rd r1 r2 ::i k.
-
-Definition transl_cond_int32u (cmp: comparison) (rd r1 r2: ireg) (k: code) :=
-  Pcompw (itest_for_cmp cmp Unsigned) rd r1 r2 ::i k.
-
-Definition transl_cond_int64s (cmp: comparison) (rd r1 r2: ireg) (k: code) :=
-  Pcompl (itest_for_cmp cmp Signed) rd r1 r2 ::i k.
-
-Definition transl_cond_int64u (cmp: comparison) (rd r1 r2: ireg) (k: code) :=
-  Pcompl (itest_for_cmp cmp Unsigned) rd r1 r2 ::i k.
-
-Definition transl_condimm_int32s (cmp: comparison) (rd r1: ireg) (n: int) (k: code) :=
-  Pcompiw (itest_for_cmp cmp Signed) rd r1 n ::i k.
-
-Definition transl_condimm_int32u (cmp: comparison) (rd r1: ireg) (n: int) (k: code) :=
-  Pcompiw (itest_for_cmp cmp Unsigned) rd r1 n ::i k.
-
-Definition transl_condimm_int64s (cmp: comparison) (rd r1: ireg) (n: int64) (k: code) :=
-  Pcompil (itest_for_cmp cmp Signed) rd r1 n ::i k.
-
-Definition transl_condimm_int64u (cmp: comparison) (rd r1: ireg) (n: int64) (k: code) :=
-  Pcompil (itest_for_cmp cmp Unsigned) rd r1 n ::i k.
+(** For OCaml code *)
+Definition addptrofs (rd rs: ireg) (n: ptrofs) := basic_to_instruction (addptrofs rd rs n).
+Definition storeind_ptr (src: ireg) (base: ireg) (ofs: ptrofs) := 
+  basic_to_instruction (storeind_ptr src base ofs).
 
-Definition transl_cond_op
-           (cond: condition) (rd: ireg) (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 (transl_cond_int32s c rd r1 r2 k)
-  | Ccompu c, a1 :: a2 :: nil =>
-      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
-      OK (transl_cond_int32u c rd r1 r2 k)
-  | Ccompimm c n, a1 :: nil =>
-      do r1 <- ireg_of a1;
-      OK (transl_condimm_int32s c rd r1 n k)
-  | Ccompuimm c n, a1 :: nil =>
-      do r1 <- ireg_of a1;
-      OK (transl_condimm_int32u c rd r1 n k)
-  | Ccompl c, a1 :: a2 :: nil =>
-      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
-      OK (transl_cond_int64s c rd r1 r2 k)
-  | Ccomplu c, a1 :: a2 :: nil =>
-      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
-      OK (transl_cond_int64u c rd r1 r2 k)
-  | Ccomplimm c n, a1 :: nil =>
-      do r1 <- ireg_of a1;
-      OK (transl_condimm_int64s c rd r1 n k)
-  | Ccompluimm c n, a1 :: nil =>
-      do r1 <- ireg_of a1;
-      OK (transl_condimm_int64u c rd r1 n k)
-(*| Ccompf c, f1 :: f2 :: nil =>
-      do r1 <- freg_of f1; do r2 <- freg_of f2;
-      let (insn, normal) := transl_cond_float c rd r1 r2 in
-      OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k)
-  | Cnotcompf c, f1 :: f2 :: nil =>
-      do r1 <- freg_of f1; do r2 <- freg_of f2;
-      let (insn, normal) := transl_cond_float c rd r1 r2 in
-      OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k)
-  | Ccompfs c, f1 :: f2 :: nil =>
-      do r1 <- freg_of f1; do r2 <- freg_of f2;
-      let (insn, normal) := transl_cond_single c rd r1 r2 in
-      OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k)
-  | Cnotcompfs c, f1 :: f2 :: nil =>
-      do r1 <- freg_of f1; do r2 <- freg_of f2;
-      let (insn, normal) := transl_cond_single c rd r1 r2 in
-      OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k)
-*)| _, _ =>
-      Error(msg "Asmgen.transl_cond_op")
-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 (Pmv r a ::i k)
-      |  _  ,  _   => Error(msg "Asmgen.Omove")
-      end
-  | Ointconst n, nil =>
-      do rd <- ireg_of res;
-      OK (loadimm32 rd n k)
-  | Olongconst n, nil =>
-      do rd <- ireg_of res;
-      OK (loadimm64 rd n k)
-(*| Ofloatconst f, nil =>
-      do rd <- freg_of res;
-      OK (if Float.eq_dec f Float.zero
-          then Pfcvtdw rd GPR0 :: k
-          else Ploadfi rd f :: k)
-  | Osingleconst f, nil =>
-      do rd <- freg_of res;
-      OK (if Float32.eq_dec f Float32.zero
-          then Pfcvtsw rd GPR0 :: k
-          else Ploadsi rd f :: k)
-*)| Oaddrsymbol s ofs, nil =>
-      do rd <- ireg_of res;
-      OK (if Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)
-          then Ploadsymbol rd s Ptrofs.zero ::i addptrofs rd rd ofs k
-          else Ploadsymbol rd s ofs ::i k)
-  | Oaddrstack n, nil =>
-      do rd <- ireg_of res;
-      OK (addptrofs rd SP n k)
-
-  | Ocast8signed, a1 :: nil =>
-      do rd <- ireg_of res; do rs <- ireg_of a1;
-      OK (Pslliw rd rs (Int.repr 24) ::i Psraiw rd rd (Int.repr 24) ::i k)
-  | Ocast16signed, a1 :: nil =>
-      do rd <- ireg_of res; do rs <- ireg_of a1;
-      OK (Pslliw rd rs (Int.repr 16) ::i Psraiw rd rd (Int.repr 16) ::i k)
-  | Oadd, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Paddw rd rs1 rs2 ::i k)
-  | Oaddimm n, a1 :: nil =>
-      do rd  <- ireg_of res; do rs <- ireg_of a1;
-      OK (addimm32 rd rs n k)
-  | Oneg, a1 :: nil =>
-      do rd  <- ireg_of res; do rs <- ireg_of a1;
-      OK (Pnegw rd rs ::i k)
-  | Osub, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Psubw rd rs1 rs2 ::i k)
-  | Omul, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Pmulw rd rs1 rs2 ::i k)
-(*| Omulhs, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Pmulhw rd rs1 rs2 :: k)
-  | Omulhu, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Pmulhuw rd rs1 rs2 :: k)
-  | Odiv, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Pdivw rd rs1 rs2 :: k)
-  | Odivu, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Pdivuw rd rs1 rs2 :: k)
-  | Omod, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Premw rd rs1 rs2 :: k)
-  | Omodu, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Premuw rd rs1 rs2 :: k)
-*)| Oand, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Pandw rd rs1 rs2 ::i k)
-  | Oandimm n, a1 :: nil =>
-      do rd  <- ireg_of res; do rs <- ireg_of a1;
-      OK (andimm32 rd rs n k)
-  | Oor, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Porw rd rs1 rs2 ::i k)
-  | Oorimm n, a1 :: nil =>
-      do rd  <- ireg_of res; do rs <- ireg_of a1;
-      OK (orimm32 rd rs n k)
-  | Oxor, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Pxorw rd rs1 rs2 ::i k)
-  | Oxorimm n, a1 :: nil =>
-      do rd  <- ireg_of res; do rs <- ireg_of a1;
-      OK (xorimm32 rd rs n k)
-  | Oshl, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Psllw rd rs1 rs2 ::i k)
-  | Oshlimm n, a1 :: nil =>
-      do rd <- ireg_of res; do rs <- ireg_of a1;
-      OK (Pslliw rd rs n ::i k)
-  | Oshr, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Psraw rd rs1 rs2 ::i k)
-  | Oshrimm n, a1 :: nil =>
-      do rd <- ireg_of res; do rs <- ireg_of a1;
-      OK (Psraiw rd rs n ::i k)
-  | Oshru, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Psrlw rd rs1 rs2 ::i k)
-  | Oshruimm n, a1 :: nil =>
-      do rd <- ireg_of res; do rs <- ireg_of a1;
-      OK (Psrliw rd rs n ::i k)
-  | Oshrximm n, a1 :: nil =>
-      do rd <- ireg_of res; do rs <- ireg_of a1;
-      OK (if Int.eq n Int.zero then Pmv rd rs ::i k else
-          Psraiw GPR31 rs (Int.repr 31) ::i
-          Psrliw GPR31 GPR31 (Int.sub Int.iwordsize n) ::i
-          Paddw GPR31 rs GPR31 ::i
-          Psraiw rd GPR31 n ::i k)
-
-  (* [Omakelong], [Ohighlong]  should not occur *)
-  | Olowlong, a1 :: nil =>
-      do rd <- ireg_of res; do rs <- ireg_of a1;
-      OK (Pcvtl2w rd rs ::i k)  
-  | Ocast32signed, a1 :: nil =>
-      do rd <- ireg_of res; do rs <- ireg_of a1;
-      OK (cast32signed rd rs k)
-  | Ocast32unsigned, a1 :: nil =>
-      do rd <- ireg_of res; do rs <- ireg_of a1;
-      assertion (ireg_eq rd rs);
-      OK (Pcvtw2l rd ::i Psllil rd rd (Int.repr 32) ::i Psrlil rd rd (Int.repr 32) ::i k)
-  | Oaddl, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Paddl rd rs1 rs2 ::i k)
-  | Oaddlimm n, a1 :: nil =>
-      do rd  <- ireg_of res; do rs <- ireg_of a1;
-      OK (addimm64 rd rs n k)
-  | Onegl, a1 :: nil =>
-      do rd  <- ireg_of res; do rs <- ireg_of a1;
-      OK (Pnegl rd rs ::i k)
-  | Osubl, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Psubl rd rs1 rs2 ::i k)
-  | Omull, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Pmull rd rs1 rs2 ::i k)
-(*| Omullhs, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Pmulhl rd rs1 rs2 :: k)
-  | Omullhu, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Pmulhul rd rs1 rs2 :: k)
-  | Odivl, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Pdivl rd rs1 rs2 :: k)
-  | Odivlu, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Pdivul rd rs1 rs2 :: k)
-  | Omodl, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Preml rd rs1 rs2 :: k)
-  | Omodlu, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Premul rd rs1 rs2 :: k)
-*)| Oandl, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Pandl rd rs1 rs2 ::i k)
-  | Oandlimm n, a1 :: nil =>
-      do rd  <- ireg_of res; do rs <- ireg_of a1;
-      OK (andimm64 rd rs n k)
-  | Oorl, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Porl rd rs1 rs2 ::i k)
-  | Oorlimm n, a1 :: nil =>
-      do rd  <- ireg_of res; do rs <- ireg_of a1;
-      OK (orimm64 rd rs n k)
-  | Oxorl, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Pxorl rd rs1 rs2 ::i k)
-  | Oxorlimm n, a1 :: nil =>
-      do rd  <- ireg_of res; do rs <- ireg_of a1;
-      OK (xorimm64 rd rs n k)
-  | Oshll, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Pslll rd rs1 rs2 ::i k)
-  | Oshllimm n, a1 :: nil =>
-      do rd <- ireg_of res; do rs <- ireg_of a1;
-      OK (Psllil rd rs n ::i k)
-  | Oshrl, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Psral rd rs1 rs2 ::i k)
-  | Oshrlimm n, a1 :: nil =>
-      do rd <- ireg_of res; do rs <- ireg_of a1;
-      OK (Psrail rd rs n ::i k)
-  | Oshrlu, a1 :: a2 :: nil =>
-      do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
-      OK (Psrll rd rs1 rs2 ::i k)
-  | Oshrluimm n, a1 :: nil =>
-      do rd <- ireg_of res; do rs <- ireg_of a1;
-      OK (Psrlil rd rs n ::i k)
-(*| Oshrxlimm n, a1 :: nil =>
-      do rd <- ireg_of res; do rs <- ireg_of a1;
-      OK (if Int.eq n Int.zero then Pmv rd rs :: k else
-          Psrail GPR31 rs (Int.repr 63) ::
-          Psrlil GPR31 GPR31 (Int.sub Int64.iwordsize' n) ::
-          Paddl GPR31 rs GPR31 ::
-          Psrail rd GPR31 n :: k)
-
-*)| Onegf, a1 :: nil =>
-      do rd <- freg_of res; do rs <- freg_of a1;
-      OK (Pfnegd rd rs ::i k)
-(*| Oabsf, a1 :: nil =>
-      do rd <- freg_of res; do rs <- freg_of a1;
-      OK (Pfabsd rd rs :: k)
-  | Oaddf, a1 :: a2 :: nil =>
-      do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
-      OK (Pfaddd rd rs1 rs2 :: k)
-  | Osubf, a1 :: a2 :: nil =>
-      do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
-      OK (Pfsubd rd rs1 rs2 :: k)
-  | Omulf, a1 :: a2 :: nil =>
-      do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
-      OK (Pfmuld rd rs1 rs2 :: k)
-  | Odivf, a1 :: a2 :: nil =>
-      do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
-      OK (Pfdivd rd rs1 rs2 :: k)
-
-  | Onegfs, a1 :: nil =>
-      do rd <- freg_of res; do rs <- freg_of a1;
-      OK (Pfnegs rd rs :: k)
-  | Oabsfs, a1 :: nil =>
-      do rd <- freg_of res; do rs <- freg_of a1;
-      OK (Pfabss rd rs :: k)
-  | Oaddfs, a1 :: a2 :: nil =>
-      do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
-      OK (Pfadds rd rs1 rs2 :: k)
-  | Osubfs, a1 :: a2 :: nil =>
-      do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
-      OK (Pfsubs rd rs1 rs2 :: k)
-  | Omulfs, a1 :: a2 :: nil =>
-      do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
-      OK (Pfmuls rd rs1 rs2 :: k)
-  | Odivfs, a1 :: a2 :: nil =>
-      do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
-      OK (Pfdivs rd rs1 rs2 :: k)
-
-  | Osingleoffloat, a1 :: nil =>
-      do rd <- freg_of res; do rs <- freg_of a1;
-      OK (Pfcvtsd rd rs :: k)
-  | Ofloatofsingle, a1 :: nil =>
-      do rd <- freg_of res; do rs <- freg_of a1;
-      OK (Pfcvtds rd rs :: k)
-
-  | Ointoffloat, a1 :: nil =>
-      do rd <- ireg_of res; do rs <- freg_of a1;
-      OK (Pfcvtwd rd rs :: k)
-  | Ointuoffloat, a1 :: nil =>
-      do rd <- ireg_of res; do rs <- freg_of a1;
-      OK (Pfcvtwud rd rs :: k)
-  | Ofloatofint, a1 :: nil =>
-      do rd <- freg_of res; do rs <- ireg_of a1;
-      OK (Pfcvtdw rd rs :: k)
-  | Ofloatofintu, a1 :: nil =>
-      do rd <- freg_of res; do rs <- ireg_of a1;
-      OK (Pfcvtdwu rd rs :: k)
-  | Ointofsingle, a1 :: nil =>
-      do rd <- ireg_of res; do rs <- freg_of a1;
-      OK (Pfcvtws rd rs :: k)
-  | Ointuofsingle, a1 :: nil =>
-      do rd <- ireg_of res; do rs <- freg_of a1;
-      OK (Pfcvtwus rd rs :: k)
-  | Osingleofint, a1 :: nil =>
-      do rd <- freg_of res; do rs <- ireg_of a1;
-      OK (Pfcvtsw rd rs :: k)
-  | Osingleofintu, a1 :: nil =>
-      do rd <- freg_of res; do rs <- ireg_of a1;
-      OK (Pfcvtswu rd rs :: k)
-
-  | Olongoffloat, a1 :: nil =>
-      do rd <- ireg_of res; do rs <- freg_of a1;
-      OK (Pfcvtld rd rs :: k)
-  | Olonguoffloat, a1 :: nil =>
-      do rd <- ireg_of res; do rs <- freg_of a1;
-      OK (Pfcvtlud rd rs :: k)
-  | Ofloatoflong, a1 :: nil =>
-      do rd <- freg_of res; do rs <- ireg_of a1;
-      OK (Pfcvtdl rd rs :: k)
-  | Ofloatoflongu, a1 :: nil =>
-      do rd <- freg_of res; do rs <- ireg_of a1;
-      OK (Pfcvtdlu rd rs :: k)
-  | Olongofsingle, a1 :: nil =>
-      do rd <- ireg_of res; do rs <- freg_of a1;
-      OK (Pfcvtls rd rs :: k)
-  | Olonguofsingle, a1 :: nil =>
-      do rd <- ireg_of res; do rs <- freg_of a1;
-      OK (Pfcvtlus rd rs :: k)
-  | Osingleoflong, a1 :: nil =>
-      do rd <- freg_of res; do rs <- ireg_of a1;
-      OK (Pfcvtsl rd rs :: k)
-  | Osingleoflongu, a1 :: nil =>
-      do rd <- freg_of res; do rs <- ireg_of a1;
-      OK (Pfcvtslu rd rs :: k)
-
-*)| Ocmp cmp, _ =>
-      do rd <- ireg_of res;
-      transl_cond_op cmp rd args k
-  
-  | _, _ =>
-      Error(msg "Asmgen.transl_op")
-  end.
-
-(** Accessing data in the stack frame. *)
-
-Definition indexed_memory_access
-        (mk_instr: ireg -> offset -> instruction)
-        (base: ireg) (ofs: ptrofs) (k: code) :=
-  match make_immed64 (Ptrofs.to_int64 ofs) with
-  | Imm64_single imm =>
-      mk_instr base (Ofsimm (Ptrofs.of_int64 imm)) ::i k
-(*| Imm64_pair hi lo =>
-      Pluil GPR31 hi :: Paddl GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm (Ptrofs.of_int64 lo)) :: k
-  | Imm64_large imm =>
-      Pmake GPR31 imm :: Paddl GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm Ptrofs.zero) :: k
-*)end.
-
-Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: code) :=
-  match ty, preg_of dst with
-  | Tint,    IR rd => OK (indexed_memory_access (Plw rd) base ofs k)
-  | Tlong,   IR rd => OK (indexed_memory_access (Pld rd) base ofs k)
-  | Tsingle, IR rd => OK (indexed_memory_access (Pfls rd) base ofs k)
-  | Tfloat,  IR rd => OK (indexed_memory_access (Pfld rd) base ofs k)
-  | Tany32,  IR rd => OK (indexed_memory_access (Plw_a rd) base ofs k)
-  | Tany64,  IR rd => OK (indexed_memory_access (Pld_a rd) base ofs k)
-  | _, _           => Error (msg "Asmgen.loadind")
-  end.
-
-Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: code) :=
-  match ty, preg_of src with
-  | Tint,    IR rd => OK (indexed_memory_access (Psw rd) base ofs k)
-  | Tlong,   IR rd => OK (indexed_memory_access (Psd rd) base ofs k)
-  | Tsingle, IR rd => OK (indexed_memory_access (Pfss rd) base ofs k)
-  | Tfloat,  IR rd => OK (indexed_memory_access (Pfsd rd) base ofs k)
-  | Tany32,  IR rd => OK (indexed_memory_access (Psw_a rd) base ofs k)
-  | Tany64,  IR rd => OK (indexed_memory_access (Psd_a rd) base ofs k)
-  | _, _           => Error (msg "Asmgen.storeind")
-  end.
-
-Definition loadind_ptr (base: ireg) (ofs: ptrofs) (dst: ireg) (k: code) :=
-  indexed_memory_access (Pld dst) base ofs k.
-
-Definition storeind_ptr (src: ireg) (base: ireg) (ofs: ptrofs) (k: code) :=
-  indexed_memory_access (Psd src) base ofs k.
-
-(** Translation of memory accesses: loads, and stores. *)
-
-Definition transl_memory_access
-     (mk_instr: ireg -> offset -> instruction)
-     (addr: addressing) (args: list mreg) (k: code) : res (list instruction) :=
-  match addr, args with
-  | Aindexed ofs, a1 :: nil =>
-      do rs <- ireg_of a1;
-      OK (indexed_memory_access mk_instr rs ofs k)
-  | Aglobal id ofs, nil =>
-      OK (Ploadsymbol GPR31 id ofs ::i (mk_instr GPR31 (Ofsimm Ptrofs.zero) ::i k))
-  | Ainstack ofs, nil =>
-      OK (indexed_memory_access mk_instr SP ofs k)
-  | _, _ =>
-      Error(msg "Asmgen.transl_memory_access")
-  end.
-
-Definition transl_load (chunk: memory_chunk) (addr: addressing)
-           (args: list mreg) (dst: mreg) (k: code) : res (list instruction) :=
-  match chunk with
-  | Mint8signed =>
-      do r <- ireg_of dst;
-      transl_memory_access (Plb r)  addr args k
-  | Mint8unsigned =>
-      do r <- ireg_of dst;
-      transl_memory_access (Plbu r) addr args k
-  | Mint16signed =>
-      do r <- ireg_of dst;
-      transl_memory_access (Plh r)  addr args k
-  | Mint16unsigned =>
-      do r <- ireg_of dst;
-      transl_memory_access (Plhu r) addr args k
-  | Mint32 =>
-      do r <- ireg_of dst;
-      transl_memory_access (Plw r)  addr args k
-  | Mint64 =>
-      do r <- ireg_of dst;
-      transl_memory_access (Pld r)  addr args k
-  | Mfloat32 =>
-      do r <- freg_of dst;
-      transl_memory_access (Pfls r) addr args k
-  | Mfloat64 =>
-      do r <- freg_of dst;
-      transl_memory_access (Pfld r) addr args k
-  | _ =>
-      Error (msg "Asmgen.transl_load")
-  end.
-
-Definition transl_store (chunk: memory_chunk) (addr: addressing)
-           (args: list mreg) (src: mreg) (k: code) : res (list instruction) :=
-  match chunk with
-  | Mint8signed | Mint8unsigned =>
-      do r <- ireg_of src;
-      transl_memory_access (Psb r)  addr args k
-  | Mint16signed | Mint16unsigned =>
-      do r <- ireg_of src;
-      transl_memory_access (Psh r)  addr args k
-  | Mint32 =>
-      do r <- ireg_of src;
-      transl_memory_access (Psw r)  addr args k
-  | Mint64 =>
-      do r <- ireg_of src;
-      transl_memory_access (Psd r)  addr args k
-  | Mfloat32 =>
-      do r <- freg_of src;
-      transl_memory_access (Pfss r) addr args k
-  | Mfloat64 =>
-      do r <- freg_of src;
-      transl_memory_access (Pfsd r) addr args k
-  | _ =>
-      Error (msg "Asmgen.transl_store")
-  end.
-
-(** Function epilogue *)
-
-Definition make_epilogue (f: Mach.function) (k: code) :=
-  loadind_ptr SP f.(fn_retaddr_ofs) GPR8 
-  (Pset RA GPR8 ::i Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) ::i k).
-
-(** Translation of a Mach instruction. *)
-
-Definition transl_instr (f: Mach.function) (i: Mach.instruction)
-                        (ep: bool) (k: code) :=
-  match i with
-  | Mgetstack ofs ty dst =>
-      loadind SP ofs ty dst k
-  | Msetstack src ofs ty =>
-      storeind src SP ofs ty k
-  | Mgetparam ofs ty dst =>
-      (* load via the frame pointer if it is valid *)
-      do c <- loadind FP ofs ty dst k;
-      OK (if ep then c
-                else loadind_ptr SP f.(fn_link_ofs) FP 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 r) =>
-      do r1 <- ireg_of r; OK (Pjal_r r1 sig :: k)
-*)| Mcall sig (inr symb) =>
-      OK ((Pcall symb) ::i k)
-(*| Mtailcall sig (inl r) =>
-      do r1 <- ireg_of r;
-      OK (make_epilogue f (Pcall :: k))
-*)| Mtailcall sig (inr symb) =>
-      OK (make_epilogue f ((Pgoto symb) ::i k))
-  | Mbuiltin ef args res =>
-      OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) ::i k)
-  | Mlabel lbl =>
-      OK (Plabel lbl ::i k)
-  | Mgoto lbl =>
-      OK (Pj_l lbl ::i k)
-  | Mcond cond args lbl =>
-      transl_cbranch cond args lbl k
-(*| Mjumptable arg tbl => do r <- ireg_of arg; OK (Pbtbl r tbl :: k)
-*)| Mreturn =>
-      OK (make_epilogue f (Pret ::i k))
-      (*OK (make_epilogue f (Pj_r RA f.(Mach.fn_sig) :: k))*)
-  | _ =>
-      Error (msg "Asmgen.transl_instr")
-  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 R10)
-  | Mop op args res => before && negb (mreg_eq res R10)
-  | _ => 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) ::i
-         Pget GPR8 RA ::i
-         storeind_ptr GPR8 SP f.(fn_retaddr_ofs) c)).
+Definition transf_program (p: Mach.program) : res Asm.program :=
+  let mbp := Machblockgen.transf_program p in
+  do abp <- Asmblockgen.transf_program mbp;
+  OK (Asm.transf_program abp).
 
 Definition transf_function (f: Mach.function) : res Asm.function :=
-  do tf <- transl_function f;
-  if zlt Ptrofs.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.
+  let mbf := Machblockgen.transf_function f in
+  do abf <- Asmblockgen.transf_function mbf;
+  OK (Asm.transf_function abf).
+
+Definition transl_code (f: Mach.function) (l: Mach.code) : res (list Asm.instruction) :=
+  let mbf := Machblockgen.transf_function f in
+  let mbc := Machblockgen.trans_code l in
+  do abc <- transl_blocks mbf mbc true;
+  OK (unfold abc).
\ No newline at end of file
diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v
index 896e9ce9..74be571d 100644
--- a/mppa_k1c/Asmgenproof.v
+++ b/mppa_k1c/Asmgenproof.v
@@ -15,1092 +15,148 @@
 Require Import Coqlib Errors.
 Require Import Integers Floats AST Linking.
 Require Import Values Memory Events Globalenvs Smallstep.
-Require Import Op Locations Mach Conventions Asm.
-Require Import Asmgen Asmgenproof0 Asmgenproof1.
+Require Import Op Locations Mach Conventions Asm Asmgen Machblockgen Asmblockgen.
+Require Import Machblockgenproof Asmblockgenproof.
 
-Definition match_prog (p: Mach.program) (tp: Asm.program) :=
-  match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp.
+Local Open Scope linking_scope.
 
-Lemma transf_program_match:
-  forall p tp, transf_program p = OK tp -> match_prog p tp.
-Proof.
-  intros. eapply match_transform_partial_program; eauto.
-Qed.
-
-Section PRESERVATION.
-
-Variable prog: Mach.program.
-Variable tprog: Asm.program.
-Hypothesis TRANSF: match_prog prog tprog.
-Let ge := Genv.globalenv prog.
-Let tge := Genv.globalenv tprog.
-
-Lemma symbols_preserved:
-  forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
-Proof (Genv.find_symbol_match TRANSF).
-
-Lemma senv_preserved:
-  Senv.equiv ge tge.
-Proof (Genv.senv_match TRANSF).
-
-Lemma functions_translated:
-  forall b f,
-  Genv.find_funct_ptr ge b = Some f ->
-  exists tf,
-  Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf.
-Proof (Genv.find_funct_ptr_transf_partial TRANSF).
-
-Lemma functions_transl:
-  forall fb f tf,
-  Genv.find_funct_ptr ge fb = Some (Internal f) ->
-  transf_function f = OK tf ->
-  Genv.find_funct_ptr tge fb = Some (Internal tf).
-Proof.
-  intros. exploit functions_translated; eauto. intros [tf' [A B]].
-  monadInv B. rewrite H0 in EQ; inv EQ; auto.
-Qed.
-
-(** * Properties of control flow *)
-
-Lemma transf_function_no_overflow:
-  forall f tf,
-  transf_function f = OK tf -> list_length_z tf.(fn_code) <= Ptrofs.max_unsigned.
-Proof.
-  intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0.
-  omega.
-Qed.
-
-Lemma exec_straight_exec:
-  forall fb f c ep tf tc c' rs m rs' m',
-  transl_code_at_pc ge (rs PC) fb f c ep tf tc ->
-  exec_straight tge tf tc rs m c' rs' m' ->
-  plus step tge (State rs m) E0 (State rs' m').
-Proof.
-  intros. inv H.
-  eapply exec_straight_steps_1; eauto.
-  eapply transf_function_no_overflow; eauto.
-  eapply functions_transl; eauto.
-Qed.
-
-Lemma exec_straight_at:
-  forall fb f c ep tf tc c' ep' tc' rs m rs' m',
-  transl_code_at_pc ge (rs PC) fb f c ep tf tc ->
-  transl_code f c' ep' = OK tc' ->
-  exec_straight tge tf tc rs m tc' rs' m' ->
-  transl_code_at_pc ge (rs' PC) fb f c' ep' tf tc'.
-Proof.
-  intros. inv H.
-  exploit exec_straight_steps_2; eauto.
-  eapply transf_function_no_overflow; eauto.
-  eapply functions_transl; eauto.
-  intros [ofs' [PC' CT']].
-  rewrite PC'. constructor; auto.
-Qed.
-
-(** The following lemmas show that the translation from Mach to Asm
-  preserves labels, in the sense that the following diagram commutes:
-<<
-                          translation
-        Mach code ------------------------ Asm instr sequence
-            |                                          |
-            | Mach.find_label lbl       find_label lbl |
-            |                                          |
-            v                                          v
-        Mach code tail ------------------- Asm instr seq tail
-                          translation
->>
-  The proof demands many boring lemmas showing that Asm constructor
-  functions do not introduce new labels.
-*)
+Definition block_passes :=
+      mkpass Machblockgenproof.match_prog
+  ::: mkpass Asmblockgenproof.match_prog
+  ::: mkpass Asm.match_prog
+  ::: pass_nil _.
 
-Section TRANSL_LABEL.
-
-Remark loadimm32_label:
-  forall r n k, tail_nolabel k (loadimm32 r n k).
-Proof.
-  intros; unfold loadimm32. destruct (make_immed32 n); TailNoLabel.
-(*unfold load_hilo32. destruct (Int.eq lo Int.zero); TailNoLabel.*)
-Qed.
-Hint Resolve loadimm32_label: labels.
-
-Remark opimm32_label:
-  forall (op: arith_name_rrr) (opimm: arith_name_rri32) r1 r2 n k,
-  (forall r1 r2 r3, nolabel (op r1 r2 r3)) ->
-  (forall r1 r2 n, nolabel (opimm r1 r2 n)) ->
-  tail_nolabel k (opimm32 op opimm r1 r2 n k).
-Proof.
-  intros; unfold opimm32. destruct (make_immed32 n); TailNoLabel.
-(*unfold load_hilo32. destruct (Int.eq lo Int.zero); TailNoLabel.*)
-Qed.
-Hint Resolve opimm32_label: labels.
-
-Remark loadimm64_label:
-  forall r n k, tail_nolabel k (loadimm64 r n k).
-Proof.
-  intros; unfold loadimm64. destruct (make_immed64 n); TailNoLabel.
-(*unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel.*)
-Qed.
-Hint Resolve loadimm64_label: labels.
-
-Remark cast32signed_label:
-  forall rd rs k, tail_nolabel k (cast32signed rd rs k).
-Proof.
-  intros; unfold cast32signed. destruct (ireg_eq rd rs); TailNoLabel.
-Qed.
-Hint Resolve cast32signed_label: labels.
-
-Remark opimm64_label:
-  forall (op: arith_name_rrr) (opimm: arith_name_rri64) r1 r2 n k,
-  (forall r1 r2 r3, nolabel (op r1 r2 r3)) ->
-  (forall r1 r2 n, nolabel (opimm r1 r2 n)) ->
-  tail_nolabel k (opimm64 op opimm r1 r2 n k).
-Proof.
-  intros; unfold opimm64. destruct (make_immed64 n); TailNoLabel.
-(*unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel.*)
-Qed.
-Hint Resolve opimm64_label: labels.
-
-Remark addptrofs_label:
-  forall r1 r2 n k, tail_nolabel k (addptrofs r1 r2 n k).
-Proof.
-  unfold addptrofs; intros. destruct (Ptrofs.eq_dec n Ptrofs.zero). TailNoLabel.
-  apply opimm64_label; TailNoLabel.
-Qed.
-Hint Resolve addptrofs_label: labels.
-(*
-Remark transl_cond_float_nolabel:
-  forall c r1 r2 r3 insn normal,
-  transl_cond_float c r1 r2 r3 = (insn, normal) -> nolabel insn.
-Proof.
-  unfold transl_cond_float; intros. destruct c; inv H; exact I.
-Qed.
-
-Remark transl_cond_single_nolabel:
-  forall c r1 r2 r3 insn normal,
-  transl_cond_single c r1 r2 r3 = (insn, normal) -> nolabel insn.
-Proof.
-  unfold transl_cond_single; intros. destruct c; inv H; exact I.
-Qed.
-*)
-Remark transl_cbranch_label:
-  forall cond args lbl k c,
-  transl_cbranch cond args lbl k = OK c -> tail_nolabel k c.
-Proof.
-  intros. unfold transl_cbranch in H. destruct cond; TailNoLabel.
-(* Ccomp *)
-  - unfold transl_comp; TailNoLabel.
-(* Ccompu *)
-  - unfold transl_comp; TailNoLabel.
-(* Ccompimm *)
-  - destruct (Int.eq n Int.zero); TailNoLabel.
-    unfold loadimm32. destruct (make_immed32 n); TailNoLabel. unfold transl_comp; TailNoLabel.
-(* Ccompuimm *)
-  - unfold transl_opt_compuimm.
-    remember (select_comp n c0) as selcomp; destruct selcomp.
-    + destruct c; TailNoLabel; contradict Heqselcomp; unfold select_comp;
-      destruct (Int.eq n Int.zero); destruct c0; discriminate.
-    + unfold loadimm32;
-      destruct (make_immed32 n); TailNoLabel; unfold transl_comp; TailNoLabel.
-(* Ccompl *)
-  - unfold transl_compl; TailNoLabel.
-(* Ccomplu *)
-  - unfold transl_compl; TailNoLabel.
-(* Ccomplimm *)
-  - destruct (Int64.eq n Int64.zero); TailNoLabel.
-    unfold loadimm64. destruct (make_immed64 n); TailNoLabel. unfold transl_compl; TailNoLabel.
-(* Ccompluimm *)
-  - unfold transl_opt_compluimm.
-    remember (select_compl n c0) as selcomp; destruct selcomp.
-    + destruct c; TailNoLabel; contradict Heqselcomp; unfold select_compl;
-      destruct (Int64.eq n Int64.zero); destruct c0; discriminate.
-    + unfold loadimm64;
-      destruct (make_immed64 n); TailNoLabel; unfold transl_compl; TailNoLabel.
-Qed.
-
-(*
-- destruct c0; simpl; TailNoLabel.
-- destruct c0; simpl; TailNoLabel.
-- destruct (Int.eq n Int.zero).
-  destruct c0; simpl; TailNoLabel.
-  apply tail_nolabel_trans with (transl_cbranch_int32s c0 x X31 lbl :: k).
-  auto with labels. destruct c0; simpl; TailNoLabel.
-- destruct (Int.eq n Int.zero).
-  destruct c0; simpl; TailNoLabel.
-  apply tail_nolabel_trans with (transl_cbranch_int32u c0 x X31 lbl :: k).
-  auto with labels. destruct c0; simpl; TailNoLabel.
-- destruct c0; simpl; TailNoLabel.
-- destruct c0; simpl; TailNoLabel.
-- destruct (Int64.eq n Int64.zero).
-  destruct c0; simpl; TailNoLabel.
-  apply tail_nolabel_trans with (transl_cbranch_int64s c0 x X31 lbl :: k).
-  auto with labels. destruct c0; simpl; TailNoLabel.
-- destruct (Int64.eq n Int64.zero).
-  destruct c0; simpl; TailNoLabel.
-  apply tail_nolabel_trans with (transl_cbranch_int64u c0 x X31 lbl :: k).
-  auto with labels. destruct c0; simpl; TailNoLabel.
-- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:F; inv EQ2.
-  apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. 
-  destruct normal; TailNoLabel.
-- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:F; inv EQ2.
-  apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. 
-  destruct normal; TailNoLabel.
-- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2.
-  apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. 
-  destruct normal; TailNoLabel.
-- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2.
-  apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. 
-  destruct normal; TailNoLabel.
-*)
-
-Remark transl_cond_op_label:
-  forall cond args r k c,
-  transl_cond_op cond r args k = OK c -> tail_nolabel k c.
-Proof.
-  intros. unfold transl_cond_op in H; destruct cond; TailNoLabel.
-- unfold transl_cond_int32s; destruct c0; simpl; TailNoLabel.
-- unfold transl_cond_int32u; destruct c0; simpl; TailNoLabel. 
-- unfold transl_condimm_int32s; destruct c0; simpl; TailNoLabel.
-- unfold transl_condimm_int32u; destruct c0; simpl; TailNoLabel.
-- unfold transl_cond_int64s; destruct c0; simpl; TailNoLabel.
-- unfold transl_cond_int64u; destruct c0; simpl; TailNoLabel. 
-- unfold transl_condimm_int64s; destruct c0; simpl; TailNoLabel.
-- unfold transl_condimm_int64u; destruct c0; simpl; TailNoLabel.
-Qed.
-
-Remark transl_op_label:
-  forall op args r k c,
-  transl_op op args r k = OK c -> tail_nolabel k c.
-Proof.
-Opaque Int.eq.
-  unfold transl_op; intros; destruct op; TailNoLabel.
-(* Omove *)
-- destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel.
-(* Oaddrsymbol *)
-- destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)); TailNoLabel.
-(* Oaddimm32 *)
-- apply opimm32_label; intros; exact I.
-(* Oandimm32 *)
-- apply opimm32_label; intros; exact I.
-(* Oorimm32 *)
-- apply opimm32_label; intros; exact I.
-(* Oxorimm32 *)
-- apply opimm32_label; intros; exact I.
-(* Oshrximm *)
-- destruct (Int.eq n Int.zero); TailNoLabel.
-(* Oaddimm64 *)
-- apply opimm64_label; intros; exact I.
-(* Oandimm64  *)
-- apply opimm64_label; intros; exact I.
-(* Oorimm64  *)
-- apply opimm64_label; intros; exact I.
-(* Oxorimm64  *)
-- apply opimm64_label; intros; exact I.
-(* Ocmp *)
-- eapply transl_cond_op_label; eauto.
-Qed.
-
-(*
-- destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel.
-- destruct (Float.eq_dec n Float.zero); TailNoLabel.
-- destruct (Float32.eq_dec n Float32.zero); TailNoLabel.
-- destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)).
-+ eapply tail_nolabel_trans; [|apply addptrofs_label]. TailNoLabel.
-+ TailNoLabel. 
-- apply opimm32_label; intros; exact I.
-- apply opimm32_label; intros; exact I.
-- apply opimm32_label; intros; exact I.
-- apply opimm32_label; intros; exact I.
-- destruct (Int.eq n Int.zero); TailNoLabel.
-- apply opimm64_label; intros; exact I.
-- apply opimm64_label; intros; exact I.
-- apply opimm64_label; intros; exact I.
-- apply opimm64_label; intros; exact I.
-- destruct (Int.eq n Int.zero); TailNoLabel.
-- eapply transl_cond_op_label; eauto.
-*)
-
-Remark indexed_memory_access_label:
-  forall (mk_instr: ireg -> offset -> instruction) base ofs k,
-  (forall r o, nolabel (mk_instr r o)) ->
-  tail_nolabel k (indexed_memory_access mk_instr base ofs k).
-Proof.
-  unfold indexed_memory_access; intros. 
-  (* destruct Archi.ptr64. *)
-  destruct (make_immed64 (Ptrofs.to_int64 ofs)); TailNoLabel.
-  (* destruct (make_immed32 (Ptrofs.to_int ofs)); TailNoLabel. *)
-Qed.
-
-Remark loadind_label:
-  forall base ofs ty dst k c,
-  loadind base ofs ty dst k = OK c -> tail_nolabel k c.
-Proof.
-  unfold loadind; intros.
-  destruct ty, (preg_of dst); inv H; apply indexed_memory_access_label; intros; exact I.
-Qed.
-
-Remark storeind_label:
-  forall src base ofs ty k c,
-  storeind src base ofs ty k = OK c -> tail_nolabel k c.
-Proof.
-  unfold storeind; intros.
-  destruct ty, (preg_of src); inv H; apply indexed_memory_access_label; intros; exact I.
-Qed.
-
-Remark loadind_ptr_label:
-  forall base ofs dst k, tail_nolabel k (loadind_ptr base ofs dst k).
-Proof.
-  intros. apply indexed_memory_access_label. intros; destruct Archi.ptr64; exact I.
-Qed.
-
-Remark storeind_ptr_label:
-  forall src base ofs k, tail_nolabel k (storeind_ptr src base ofs k).
-Proof.
-  intros. apply indexed_memory_access_label. intros; destruct Archi.ptr64; exact I.
-Qed.
+Definition match_prog := pass_match (compose_passes block_passes).
 
-Remark transl_memory_access_label:
-  forall (mk_instr: ireg -> offset -> instruction) addr args k c,
-  (forall r o, nolabel (mk_instr r o)) ->
-  transl_memory_access mk_instr addr args k = OK c ->
-  tail_nolabel k c.
-Proof.
-  unfold transl_memory_access; intros; destruct addr; TailNoLabel; apply indexed_memory_access_label; auto. 
-Qed.
-
-Remark make_epilogue_label:
-  forall f k, tail_nolabel k (make_epilogue f k).
-Proof.
-  unfold make_epilogue; intros. eapply tail_nolabel_trans. apply loadind_ptr_label. TailNoLabel.
-Qed.
-
-Lemma transl_instr_label:
-  forall f i ep k c,
-  transl_instr f i ep k = OK c ->
-  match i with Mlabel lbl => c = Plabel lbl ::i k | _ => tail_nolabel k c end.
-Proof.
-  unfold transl_instr; intros; destruct i; TailNoLabel.
-(* loadind *)
-- eapply loadind_label; eauto.
-(* storeind *)
-- eapply storeind_label; eauto.
-(* Mgetparam *)
-- destruct ep. eapply loadind_label; eauto.
-  eapply tail_nolabel_trans. apply loadind_ptr_label. eapply loadind_label; eauto. 
-(* transl_op *)
-- eapply transl_op_label; eauto.
-(* transl_load *)
-- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I.
-(* transl store *)
-- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I.
-- destruct s0; monadInv H; TailNoLabel.
-- destruct s0; monadInv H; eapply tail_nolabel_trans
-  ; [eapply make_epilogue_label|TailNoLabel].
-- eapply transl_cbranch_label; eauto.
-- eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel].
-Qed.
-(*
-
-
-- eapply transl_op_label; eauto.
-- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I.
-- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I.
-- destruct s0; monadInv H; (eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]).
-- eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel].
-*)
-
-Lemma transl_instr_label':
-  forall lbl f i ep k c,
-  transl_instr f i ep k = OK c ->
-  find_label lbl c = if Mach.is_label lbl i then Some k else find_label lbl k.
-Proof.
-  intros. exploit transl_instr_label; eauto.
-  destruct i; try (intros [A B]; apply B).
-  intros. subst c. simpl. auto.
-Qed.
-
-Lemma transl_code_label:
-  forall lbl f c ep tc,
-  transl_code f c ep = OK tc ->
-  match Mach.find_label lbl c with
-  | None => find_label lbl tc = None
-  | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_code f c' false = OK tc'
-  end.
-Proof.
-  induction c; simpl; intros.
-  inv H. auto.
-  monadInv H. rewrite (transl_instr_label' lbl _ _ _ _ _ EQ0).
-  generalize (Mach.is_label_correct lbl a).
-  destruct (Mach.is_label lbl a); intros.
-  subst a. simpl in EQ. exists x; auto.
-  eapply IHc; eauto.
-Qed.
-
-Lemma transl_find_label:
-  forall lbl f tf,
-  transf_function f = OK tf ->
-  match Mach.find_label lbl f.(Mach.fn_code) with
-  | None => find_label lbl tf.(fn_code) = None
-  | Some c => exists tc, find_label lbl tf.(fn_code) = Some tc /\ transl_code f c false = OK tc
-  end.
-Proof.
-  intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0.
-  monadInv EQ. rewrite transl_code'_transl_code in EQ0. unfold fn_code. 
-  simpl. destruct (storeind_ptr_label GPR8 GPR12 (fn_retaddr_ofs f) x) as [A B]. 
-  (* destruct B. *)
-  eapply transl_code_label; eauto.
-Qed.
-
-End TRANSL_LABEL.
-
-(** A valid branch in a piece of Mach code translates to a valid ``go to''
-  transition in the generated Asm code. *)
-
-Lemma find_label_goto_label:
-  forall f tf lbl rs m c' b ofs,
-  Genv.find_funct_ptr ge b = Some (Internal f) ->
-  transf_function f = OK tf ->
-  rs PC = Vptr b ofs ->
-  Mach.find_label lbl f.(Mach.fn_code) = Some c' ->
-  exists tc', exists rs',
-    goto_label tf lbl rs m = Next rs' m
-  /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc'
-  /\ forall r, r <> PC -> rs'#r = rs#r.
-Proof.
-  intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2.
-  intros [tc [A B]].
-  exploit label_pos_code_tail; eauto. instantiate (1 := 0).
-  intros [pos' [P [Q R]]].
-  exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))).
-  split. unfold goto_label. rewrite P. rewrite H1. auto.
-  split. rewrite Pregmap.gss. constructor; auto.
-  rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q.
-  auto. omega.
-  generalize (transf_function_no_overflow _ _ H0). omega.
-  intros. apply Pregmap.gso; auto.
+Lemma transf_program_match:
+  forall p tp, Asmgen.transf_program p = OK tp -> match_prog p tp.
+Proof.
+  intros p tp H.
+  unfold Asmgen.transf_program in H. apply bind_inversion in H. destruct H.
+  inversion_clear H. inversion H1. remember (Machblockgen.transf_program p) as mbp.
+  unfold match_prog; simpl.
+  exists mbp; split. apply Machblockgenproof.transf_program_match; auto.
+  exists x; split. apply Asmblockgenproof.transf_program_match; auto.
+  exists tp; split. apply Asm.transf_program_match; auto. auto.
+Qed.
+
+(** Return Address Offset *)
+
+Definition return_address_offset (f: Mach.function) (c: Mach.code) (ofs: ptrofs) : Prop :=
+  Asmblockgenproof.return_address_offset (Machblockgen.transf_function f) (Machblockgen.trans_code c) ofs.
+
+
+(* TODO: put this proof in Machblocgen ? (it is specific to Machblocgen) *) 
+Lemma trans_code_monotonic c i b l:
+   trans_code c = b::l ->
+   exists l', exists b', trans_code (i::c) = l' ++ (b'::l).
+Proof.
+  destruct c as [|i' c]. { rewrite trans_code_equation; intros; congruence. }
+  destruct (get_code_nature (i :: i':: c)) eqn:GCNIC.
+  - apply get_code_nature_empty in GCNIC. discriminate.
+  - (* i=label *) 
+    destruct i; try discriminate.
+    rewrite! trans_code_equation;
+    remember (to_bblock (Mlabel l0 :: i' :: c)) as b0.
+    destruct b0 as [b0 c0].
+    exploit to_bblock_label; eauto.
+    intros (H1 & H2). rewrite H2; simpl; clear H2.
+    intros H2; inversion H2; subst.
+    exists nil; simpl; eauto.
+  - (*i=basic *) 
+    rewrite! trans_code_equation; destruct (to_basic_inst i) eqn:TBI; [| destruct i; discriminate].
+    destruct (cn_eqdec (get_code_nature (i':: c)) IsLabel).
+    + (* i'=label *) remember (to_bblock (i :: i' :: c)) as b1.
+      destruct b1 as [b1 c1].
+      assert (X: c1 = i'::c).
+      {  generalize Heqb1; clear Heqb1. 
+         unfold to_bblock.
+         erewrite to_bblock_header_noLabel; try congruence.
+         destruct i'; try discriminate.
+         destruct i; try discriminate; simpl;
+         intro X; inversion X; auto.
+      }
+      subst c1.
+      rewrite !trans_code_equation. intro H1; rewrite H1.
+      exists (b1 :: nil). simpl; eauto.
+    + (* i'<>label *) remember (to_bblock (i :: i' :: c)) as b1.
+      destruct b1 as [b1 c1].
+      remember (to_bblock (i' :: c)) as b2.
+      destruct b2 as [b2 c2].
+      intro H1; assert (X: c1=c2).
+      {  generalize Heqb1, Heqb2; clear Heqb1 Heqb2. 
+         unfold to_bblock.
+         erewrite to_bblock_header_noLabel; try congruence.
+         destruct i'; simpl in * |- ; try congruence;
+         destruct i; try discriminate; simpl;
+          try (destruct (to_bblock_body c) as [xx yy], (to_bblock_exit yy);
+              intros X1 X2; inversion X1; inversion X2; auto).
+      }
+      subst; inversion H1.
+      exists nil; simpl; eauto.
+ - (* i=cfi *)
+   remember (to_cfi i) as cfi.
+   intros H. destruct cfi.
+   + erewrite trans_code_cfi; eauto.
+     rewrite H.
+     refine (ex_intro _ (_::nil) _). simpl; eauto.
+   + destruct i; simpl in * |-; try congruence.
+Qed.
+
+Lemma Mach_Machblock_tail sg ros c c1 c2: c1=(Mcall sg ros :: c) -> is_tail c1 c2 -> 
+  exists b, (* Machblock.exit b = Some (Machblock.MBcall sg ros) /\ *) 
+     is_tail (b :: trans_code c) (trans_code c2).
+Proof.
+  intro H; induction 1. 
+  - intros; subst.
+    rewrite (trans_code_equation (Mcall sg ros :: c)).
+    simpl.
+    eapply ex_intro; eauto with coqlib.
+  - intros; exploit IHis_tail; eauto. clear IHis_tail.
+    intros (b & Hb).
+    + inversion Hb; clear Hb.
+      * exploit (trans_code_monotonic c2 i); eauto.
+        intros (l' & b' & Hl'); rewrite Hl'.
+        simpl; eauto with coqlib.
+      * exploit (trans_code_monotonic c2 i); eauto.
+        intros (l' & b' & Hl'); rewrite Hl'.
+        simpl; eapply ex_intro.
+        eapply is_tail_trans; eauto with coqlib.
 Qed.
 
-(** Existence of return addresses *)
-
 Lemma return_address_exists:
   forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) ->
   exists ra, return_address_offset f c ra.
 Proof.
-  intros. eapply Asmgenproof0.return_address_exists; eauto.
-- intros. exploit transl_instr_label; eauto.
-  destruct i; try (intros [A B]; apply A). intros. subst c0. repeat constructor.
-- intros. monadInv H0.
-  destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. monadInv EQ.
-  rewrite transl_code'_transl_code in EQ0.
-  exists x; exists true; split; auto. unfold fn_code.
-  constructor. apply is_tail_cons. apply (storeind_ptr_label GPR8 GPR12 (fn_retaddr_ofs f0) x).
-- exact transf_function_no_overflow.
-Qed.
-
-(** * Proof of semantic preservation *)
-
-(** Semantic preservation is proved using simulation diagrams
-  of the following form.
-<<
-           st1 --------------- st2
-            |                   |
-           t|                  *|t
-            |                   |
-            v                   v
-           st1'--------------- st2'
->>
-  The invariant is the [match_states] predicate below, which includes:
-- The Asm code pointed by the PC register is the translation of
-  the current Mach code sequence.
-- Mach register values and Asm register values agree.
-*)
-
-Inductive match_states: Mach.state -> Asm.state -> Prop :=
-  | match_states_intro:
-      forall s fb sp c ep ms m m' rs f tf tc
-        (STACKS: match_stack ge s)
-        (FIND: Genv.find_funct_ptr ge fb = Some (Internal f))
-        (MEXT: Mem.extends m m')
-        (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc)
-        (AG: agree ms sp rs)
-        (DXP: ep = true -> rs#FP = parent_sp s),
-      match_states (Mach.State s fb sp c ms m)
-                   (Asm.State rs m')
-  | match_states_call:
-      forall s fb ms m m' rs
-        (STACKS: match_stack ge s)
-        (MEXT: Mem.extends m m')
-        (AG: agree ms (parent_sp s) rs)
-        (ATPC: rs PC = Vptr fb Ptrofs.zero)
-        (ATLR: rs RA = parent_ra s),
-      match_states (Mach.Callstate s fb ms m)
-                   (Asm.State rs m')
-  | match_states_return:
-      forall s ms m m' rs
-        (STACKS: match_stack ge s)
-        (MEXT: Mem.extends m m')
-        (AG: agree ms (parent_sp s) rs)
-        (ATPC: rs PC = parent_ra s),
-      match_states (Mach.Returnstate s ms m)
-                   (Asm.State rs m').
-
-Lemma exec_straight_steps:
-  forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2,
-  match_stack ge s ->
-  Mem.extends m2 m2' ->
-  Genv.find_funct_ptr ge fb = Some (Internal f) ->
-  transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc ->
-  (forall k c (TR: transl_instr f i ep k = OK c),
-   exists rs2,
-       exec_straight tge tf c rs1 m1' k rs2 m2'
-    /\ agree ms2 sp rs2
-    /\ (it1_is_parent ep i = true -> rs2#FP = parent_sp s)) ->
-  exists st',
-  plus step tge (State rs1 m1') E0 st' /\
-  match_states (Mach.State s fb sp c ms2 m2) st'.
-Proof.
-  intros. inversion H2. subst. monadInv H7.
-  exploit H3; eauto. intros [rs2 [A [B C]]].
-  exists (State rs2 m2'); split.
-  eapply exec_straight_exec; eauto.
-  econstructor; eauto. eapply exec_straight_at; eauto.
-Qed.
-
-Lemma exec_straight_steps_goto:
-  forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c',
-  match_stack ge s ->
-  Mem.extends m2 m2' ->
-  Genv.find_funct_ptr ge fb = Some (Internal f) ->
-  Mach.find_label lbl f.(Mach.fn_code) = Some c' ->
-  transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc ->
-  it1_is_parent ep i = false ->
-  (forall k c (TR: transl_instr f i ep k = OK c),
-   exists jmp, exists k', exists rs2,
-       exec_straight tge tf c rs1 m1' (jmp :: k') rs2 m2'
-    /\ agree ms2 sp rs2
-    /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') ->
-  exists st',
-  plus step tge (State rs1 m1') E0 st' /\
-  match_states (Mach.State s fb sp c' ms2 m2) st'.
-Proof.
-  intros. inversion H3. subst. monadInv H9.
-  exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]].
-  generalize (functions_transl _ _ _ H7 H8); intro FN.
-  generalize (transf_function_no_overflow _ _ H8); intro NOOV.
-  exploit exec_straight_steps_2; eauto.
-  intros [ofs' [PC2 CT2]].
-  exploit find_label_goto_label; eauto.
-  intros [tc' [rs3 [GOTO [AT' OTH]]]].
-  exists (State rs3 m2'); split.
-  eapply plus_right'.
-  eapply exec_straight_steps_1; eauto.
-  econstructor; eauto.
-  eapply find_instr_tail. eauto.
-  rewrite C. eexact GOTO.
-  traceEq.
-  econstructor; eauto.
-  apply agree_exten with rs2; auto with asmgen.
-  congruence.
-Qed.
-
-Lemma exec_straight_opt_steps_goto:
-  forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c',
-  match_stack ge s ->
-  Mem.extends m2 m2' ->
-  Genv.find_funct_ptr ge fb = Some (Internal f) ->
-  Mach.find_label lbl f.(Mach.fn_code) = Some c' ->
-  transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc ->
-  it1_is_parent ep i = false ->
-  (forall k c (TR: transl_instr f i ep k = OK c),
-   exists jmp, exists k', exists rs2,
-       exec_straight_opt tge tf c rs1 m1' (jmp :: k') rs2 m2'
-    /\ agree ms2 sp rs2
-    /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') ->
-  exists st',
-  plus step tge (State rs1 m1') E0 st' /\
-  match_states (Mach.State s fb sp c' ms2 m2) st'.
-Proof.
-  intros. inversion H3. subst. monadInv H9.
-  exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]].
-  generalize (functions_transl _ _ _ H7 H8); intro FN.
-  generalize (transf_function_no_overflow _ _ H8); intro NOOV.
-  inv A.
-- exploit find_label_goto_label; eauto.
-  intros [tc' [rs3 [GOTO [AT' OTH]]]].
-  exists (State rs3 m2'); split.
-  apply plus_one. econstructor; eauto.
-  eapply find_instr_tail. eauto.
-  rewrite C. eexact GOTO.
-  econstructor; eauto.
-  apply agree_exten with rs2; auto with asmgen.
-  congruence.
-- exploit exec_straight_steps_2; eauto.
-  intros [ofs' [PC2 CT2]].
-  exploit find_label_goto_label; eauto.
-  intros [tc' [rs3 [GOTO [AT' OTH]]]].
-  exists (State rs3 m2'); split.
-  eapply plus_right'.
-  eapply exec_straight_steps_1; eauto.
-  econstructor; eauto.
-  eapply find_instr_tail. eauto.
-  rewrite C. eexact GOTO.
-  traceEq.
-  econstructor; eauto.
-  apply agree_exten with rs2; auto with asmgen.
-  congruence.
-Qed.
-
-(** We need to show that, in the simulation diagram, we cannot
-  take infinitely many Mach transitions that correspond to zero
-  transitions on the Asm side.  Actually, all Mach transitions
-  correspond to at least one Asm transition, except the
-  transition from [Machsem.Returnstate] to [Machsem.State].
-  So, the following integer measure will suffice to rule out
-  the unwanted behaviour. *)
-
-Definition measure (s: Mach.state) : nat :=
-  match s with
-  | Mach.State _ _ _ _ _ _ => 0%nat
-  | Mach.Callstate _ _ _ _ => 0%nat
-  | Mach.Returnstate _ _ _ => 1%nat
-  end.
-
-Remark preg_of_not_FP: forall r, negb (mreg_eq r R10) = true -> IR FP <> preg_of r.
-Proof.
-  intros. change (IR FP) with (preg_of R10). red; intros.
-  exploit preg_of_injective; eauto. intros; subst r; discriminate.
-Qed.
-
-(** This is the simulation diagram.  We prove it by case analysis on the Mach transition. *)
-
-Theorem step_simulation:
-  forall S1 t S2, Mach.step return_address_offset ge S1 t S2 ->
-  forall S1' (MS: match_states S1 S1'),
-  (exists S2', plus step tge S1' t S2' /\ match_states S2 S2')
-  \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat.
-Proof.
-  induction 1; intros; inv MS.
-
-- (* Mlabel *)
-  left; eapply exec_straight_steps; eauto; intros.
-  monadInv TR. econstructor; split. apply exec_straight_one. simpl; eauto. auto.
-  split. apply agree_nextinstr; auto. simpl; congruence.
-
-- (* Mgetstack *)
-  unfold load_stack in H.
-  exploit Mem.loadv_extends; eauto. intros [v' [A B]].
-  rewrite (sp_val _ _ _ AG) in A.
-  left; eapply exec_straight_steps; eauto. intros. simpl in TR.
-  exploit loadind_correct; eauto with asmgen. intros [rs' [P [Q R]]].
-  exists rs'; split. eauto.
-  split. eapply agree_set_mreg; eauto with asmgen. congruence.
-  simpl; congruence.
-
-
-- (* Msetstack *)
-  unfold store_stack in H.
-  assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto.
-  exploit Mem.storev_extends; eauto. intros [m2' [A B]].
-  left; eapply exec_straight_steps; eauto.
-  rewrite (sp_val _ _ _ AG) in A. intros. simpl in TR.
-  inversion TR.
-  exploit storeind_correct; eauto with asmgen. intros [rs' [P Q]].
-  exists rs'; split. eauto.
-  split. eapply agree_undef_regs; eauto with asmgen.
-  simpl; intros. rewrite Q; auto with asmgen.
-
-- (* Mgetparam *)
-  assert (f0 = f) by congruence; subst f0.
-  unfold load_stack in *.
-  exploit Mem.loadv_extends. eauto. eexact H0. auto.
-  intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A.
-  exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'.
-  exploit Mem.loadv_extends. eauto. eexact H1. auto.
-  intros [v' [C D]].
-(* Opaque loadind. *)
-  left; eapply exec_straight_steps; eauto; intros. monadInv TR.
-  destruct ep.
-(* GPR31 contains parent *)
-  exploit loadind_correct. eexact EQ.
-  instantiate (2 := rs0). rewrite DXP; eauto. congruence.
-  intros [rs1 [P [Q R]]].
-  exists rs1; split. eauto.
-  split. eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen.
-  simpl; intros. rewrite R; auto with asmgen.
-  apply preg_of_not_FP; auto.
-(* GPR11 does not contain parent *)
-  rewrite chunk_of_Tptr in A. 
-  exploit loadind_ptr_correct. eexact A. congruence. intros [rs1 [P [Q R]]].
-  exploit loadind_correct. eexact EQ. instantiate (2 := rs1). rewrite Q. eauto. congruence.
-  intros [rs2 [S [T U]]].
-  exists rs2; split. eapply exec_straight_trans; eauto.
-  split. eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto.
-  instantiate (1 := rs1#FP <- (rs2#FP)). intros.
-  rewrite Pregmap.gso; auto with asmgen.
-  congruence.
-  intros. unfold Pregmap.set. destruct (PregEq.eq r' FP). congruence. auto with asmgen.
-  simpl; intros. rewrite U; auto with asmgen.
-  apply preg_of_not_FP; auto.
-- (* Mop *)
-  assert (eval_operation tge sp op (map rs args) m = Some v).
-    rewrite <- H. apply eval_operation_preserved. exact symbols_preserved.
-  exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. eexact H0.
-  intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A.
-  left; eapply exec_straight_steps; eauto; intros. simpl in TR.
-  exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]].
-  exists rs2; split. eauto. split. auto.
-  apply agree_set_undef_mreg with rs0; auto. 
-  apply Val.lessdef_trans with v'; auto.
-  simpl; intros. destruct (andb_prop _ _ H1); clear H1.
-  rewrite R; auto. apply preg_of_not_FP; auto.
-Local Transparent destroyed_by_op.
-  destruct op; simpl; auto; congruence.
-
-- (* Mload *)
-  assert (eval_addressing tge sp addr (map rs args) = Some a).
-    rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
-  exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1.
-  intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A.
-  exploit Mem.loadv_extends; eauto. intros [v' [C D]].
-  left; eapply exec_straight_steps; eauto; intros. simpl in TR.
-  inversion TR.
-  exploit transl_load_correct; eauto.
-  intros [rs2 [P [Q R]]].
-  exists rs2; split. eauto.
-  split. eapply agree_set_undef_mreg; eauto. congruence.
-  intros; auto with asmgen.
-  simpl; congruence.
-
-
-- (* Mstore *)
-  assert (eval_addressing tge sp addr (map rs args) = Some a).
-    rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
-  exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1.
-  intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A.
-  assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto.
-  exploit Mem.storev_extends; eauto. intros [m2' [C D]].
-  left; eapply exec_straight_steps; eauto.
-  intros. simpl in TR.
-  inversion TR.
-  exploit transl_store_correct; eauto. intros [rs2 [P Q]].
-  exists rs2; split. eauto.
-  split. eapply agree_undef_regs; eauto with asmgen.
-  simpl; congruence.
-
-- (* Mcall *)
-  assert (f0 = f) by congruence.  subst f0.
-  inv AT.
-  assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned).
-    eapply transf_function_no_overflow; eauto.
-  destruct ros as [rf|fid]; simpl in H; monadInv H5.
-(*
-+ (* Indirect call *)
-  assert (rs rf = Vptr f' Ptrofs.zero).
-    destruct (rs rf); try discriminate.
-    revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence.
-  assert (rs0 x0 = Vptr f' Ptrofs.zero).
-    exploit ireg_val; eauto. rewrite H5; intros LD; inv LD; auto.
-  generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1.
-  assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x).
-    econstructor; eauto.
-  exploit return_address_offset_correct; eauto. intros; subst ra.
-  left; econstructor; split.
-  apply plus_one. eapply exec_step_internal. Simpl. rewrite <- H2; simpl; eauto.
-  eapply functions_transl; eauto. eapply find_instr_tail; eauto.
-  simpl. eauto.
-  econstructor; eauto.
-  econstructor; eauto.
-  eapply agree_sp_def; eauto.
-  simpl. eapply agree_exten; eauto. intros. Simpl.
-  Simpl. rewrite <- H2. auto.
-*)
-+ (* Direct call *)
-  generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1.
-  assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x).
-    econstructor; eauto.
-  exploit return_address_offset_correct; eauto. intros; subst ra.
-  left; econstructor; split.
-  apply plus_one. eapply exec_step_internal. eauto.
-  eapply functions_transl; eauto. eapply find_instr_tail; eauto.
-  simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. eauto.
-  econstructor; eauto.
-  econstructor; eauto.
-  eapply agree_sp_def; eauto.
-  simpl. eapply agree_exten; eauto. intros. Simpl.
-  Simpl. rewrite <- H2. auto.
-
-- (* Mtailcall *)
-  assert (f0 = f) by congruence.  subst f0.
-  inversion AT; subst.
-  assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned).
-    eapply transf_function_no_overflow; eauto.  exploit Mem.loadv_extends. eauto. eexact H1. auto. simpl. intros [parent' [A B]].
-  destruct ros as [rf|fid]; simpl in H; monadInv H7.
-(*
-+ (* Indirect call *)
-  assert (rs rf = Vptr f' Ptrofs.zero).
-    destruct (rs rf); try discriminate.
-    revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence.
-  assert (rs0 x0 = Vptr f' Ptrofs.zero).
-    exploit ireg_val; eauto. rewrite H7; intros LD; inv LD; auto.
-  exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). 
-  exploit exec_straight_steps_2; eauto using functions_transl.                      
-  intros (ofs' & P & Q).
-  left; econstructor; split.
-  (* execution *)
-  eapply plus_right'. eapply exec_straight_exec; eauto.
-  econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q.
-  simpl. reflexivity.
-  traceEq.
-  (* match states *)
-  econstructor; eauto.
-  apply agree_set_other; auto with asmgen.
-  Simpl. rewrite Z by (rewrite <- (ireg_of_eq _ _ EQ1); eauto with asmgen). assumption. 
-*)
-+ (* Direct call *)
-  exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). 
-  exploit exec_straight_steps_2; eauto using functions_transl.                      
-  intros (ofs' & P & Q).
-  left; econstructor; split.
-  (* execution *)
-  eapply plus_right'. eapply exec_straight_exec; eauto.
-  econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q.
-  simpl. reflexivity.
-  traceEq.
-  (* match states *)
-  econstructor; eauto.
-  { apply agree_set_other.
-    - econstructor; auto with asmgen.
-      + apply V.
-      + intro r. destruct r; apply V; auto.
-    - eauto with asmgen. }
-  { Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. auto. }
-
-- (* Mbuiltin *)
-  inv AT. monadInv H4.
-  exploit functions_transl; eauto. intro FN.
-  generalize (transf_function_no_overflow _ _ H3); intro NOOV.
-  exploit builtin_args_match; eauto. intros [vargs' [P Q]].
-  exploit external_call_mem_extends; eauto.
-  intros [vres' [m2' [A [B [C D]]]]].
-  left. econstructor; split. apply plus_one.
-  eapply exec_step_builtin. eauto. eauto.
-  eapply find_instr_tail; eauto.
-  erewrite <- sp_val by eauto.
-  eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved.
-  eapply external_call_symbols_preserved; eauto. apply senv_preserved.
-  eauto.
-  econstructor; eauto.
-  instantiate (2 := tf); instantiate (1 := x).
-  unfold nextinstr. rewrite Pregmap.gss.
-  rewrite set_res_other. rewrite undef_regs_other_2. rewrite Pregmap.gso by congruence. 
-  rewrite <- H1. simpl. econstructor; eauto.
-  eapply code_tail_next_int; eauto.
-  rewrite preg_notin_charact. intros. auto with asmgen.
-  auto with asmgen.
-  apply agree_nextinstr. eapply agree_set_res; auto.
-  eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto. apply Pregmap.gso; auto with asmgen.
-  congruence.
-
-- (* Mgoto *)
-  assert (f0 = f) by congruence. subst f0.
-  inv AT. monadInv H4.
-  exploit find_label_goto_label; eauto. intros [tc' [rs' [GOTO [AT2 INV]]]].
-  left; exists (State rs' m'); split.
-  apply plus_one. econstructor; eauto.
-  eapply functions_transl; eauto.
-  eapply find_instr_tail; eauto.
-  simpl; eauto.
-  econstructor; eauto.
-  eapply agree_exten; eauto with asmgen.
-  congruence.
-- (* Mcond true *)
-  assert (f0 = f) by congruence. subst f0.
-  exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC.
-  left; eapply exec_straight_opt_steps_goto; eauto.
-  intros. simpl in TR.
-  inversion TR.
-  exploit transl_cbranch_correct_true; eauto. intros (rs' & jmp & A & B & C).
-  exists jmp; exists k; exists rs'.
-  split. eexact A. 
-  split. apply agree_exten with rs0; auto with asmgen.
-  exact B. 
-- (* Mcond false *)
-  exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC.
-  left; eapply exec_straight_steps; eauto. intros. simpl in TR.
-  inversion TR.
-  exploit transl_cbranch_correct_false; eauto. intros (rs' & A & B).
-  exists rs'.
-  split. eexact A.
-  split. apply agree_exten with rs0; auto with asmgen.
-  simpl. congruence.
-- (* Mjumptable *)
-  assert (f0 = f) by congruence. subst f0.
-  inv AT. monadInv H6.
-(*
-  exploit functions_transl; eauto. intro FN.
-  generalize (transf_function_no_overflow _ _ H5); intro NOOV.
-  exploit find_label_goto_label. eauto. eauto.
-  instantiate (2 := rs0#X5 <- Vundef #X31 <- Vundef).
-  Simpl. eauto.
-  eauto.
-  intros [tc' [rs' [A [B C]]]].
-  exploit ireg_val; eauto. rewrite H. intros LD; inv LD.
-  left; econstructor; split.
-  apply plus_one. econstructor; eauto.
-  eapply find_instr_tail; eauto.
-  simpl. rewrite <- H9. unfold Mach.label in H0; unfold label; rewrite H0. eexact A.
-  econstructor; eauto.
-  eapply agree_undef_regs; eauto.
-  simpl. intros. rewrite C; auto with asmgen. Simpl.
-  congruence.
-*)
-- (* Mreturn *)
-  assert (f0 = f) by congruence. subst f0.
-  inversion AT; subst. simpl in H6; monadInv H6.
-  assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned).
-    eapply transf_function_no_overflow; eauto.
-  exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z).
-  exploit exec_straight_steps_2; eauto using functions_transl.                      
-  intros (ofs' & P & Q).
-  left; econstructor; split.
-  (* execution *)
-  eapply plus_right'. eapply exec_straight_exec; eauto.
-  econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q.
-  simpl. reflexivity.
-  traceEq.
-  (* match states *)
-  econstructor; eauto.
-  apply agree_set_other; auto with asmgen.
-
-- (* internal function *)
-  exploit functions_translated; eauto. intros [tf [A B]]. monadInv B.
-  generalize EQ; intros EQ'. monadInv EQ'.
-  destruct (zlt Ptrofs.max_unsigned (list_length_z x0.(fn_code))); inversion EQ1. clear EQ1. subst x0.
-  unfold store_stack in *.
-  exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl.
-  intros [m1' [C D]].
-  exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto.
-  intros [m2' [F G]].
-  simpl chunk_of_type in F.
-  exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto.
-  intros [m3' [P Q]].
-  (* Execution of function prologue *)
-  monadInv EQ0. rewrite transl_code'_transl_code in EQ1.
-  set (tfbody := Pallocframe (fn_stacksize f) (fn_link_ofs f) ::i
-                 Pget GPR8 RA ::i
-                 storeind_ptr GPR8 SP (fn_retaddr_ofs f) x0) in *.
-  set (tf := {| fn_sig := Mach.fn_sig f; fn_code := tfbody |}) in *.
-  set (rs2 := nextinstr (rs0#FP <- (parent_sp s) #SP <- sp #GPR31 <- Vundef)).
-  exploit (Pget_correct tge tf GPR8 RA (storeind_ptr GPR8 SP (fn_retaddr_ofs f) x0) rs2 m2'); auto.
-  intros (rs' & U' & V').
-  exploit (storeind_ptr_correct tge tf SP (fn_retaddr_ofs f) GPR8 x0 rs' m2').
-    rewrite chunk_of_Tptr in P.
-    assert (rs' GPR8 = rs0 RA). { apply V'. }
-    assert (rs' GPR12 = rs2 GPR12). { apply V'; discriminate. }
-    rewrite H3. rewrite H4.
-    (* change (rs' GPR8) with (rs0 RA). *)
-    rewrite ATLR.
-    change (rs2 GPR12) with sp. eexact P.
-    congruence. congruence.
-  intros (rs3 & U & V).
-  assert (EXEC_PROLOGUE:
-            exec_straight tge tf
-              tf.(fn_code) rs0 m'
-              x0 rs3 m3').
-  { change (fn_code tf) with tfbody; unfold tfbody.
-    apply exec_straight_step with rs2 m2'.
-    unfold exec_instr. rewrite C. fold sp.
-    rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. rewrite F. reflexivity.
-    reflexivity.
-    eapply exec_straight_trans.
-    - eexact U'.
-    - eexact U. }
-  exploit exec_straight_steps_2; eauto using functions_transl. omega. constructor.
-  intros (ofs' & X & Y).                    
-  left; exists (State rs3 m3'); split.
-  eapply exec_straight_steps_1; eauto. omega. constructor.
-  econstructor; eauto.
-  rewrite X; econstructor; eauto. 
-  apply agree_exten with rs2; eauto with asmgen.
-  unfold rs2. 
-  apply agree_nextinstr. apply agree_set_other; auto with asmgen.
-  apply agree_change_sp with (parent_sp s). 
-  apply agree_undef_regs with rs0. auto.
-Local Transparent destroyed_at_function_entry.
-  simpl; intros; Simpl.
-  unfold sp; congruence.
-
   intros.
-  assert (r <> GPR31). { contradict H3; rewrite H3; unfold data_preg; auto. }
-  rewrite V.
-  assert (r <> GPR8). { contradict H3; rewrite H3; unfold data_preg; auto. }
-  assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. }
-  rewrite H6; auto.
-  contradict H3; rewrite H3; unfold data_preg; auto.
-  contradict H3; rewrite H3; unfold data_preg; auto.
-  contradict H3; rewrite H3; unfold data_preg; auto.
-  intros. rewrite V by auto with asmgen.
-  assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. }
-  rewrite H4 by auto with asmgen. reflexivity.
-
-- (* external function *)
-  exploit functions_translated; eauto.
-  intros [tf [A B]]. simpl in B. inv B.
-  exploit extcall_arguments_match; eauto.
-  intros [args' [C D]].
-  exploit external_call_mem_extends; eauto.
-  intros [res' [m2' [P [Q [R S]]]]].
-  left; econstructor; split.
-  apply plus_one. eapply exec_step_external; eauto.
-  eapply external_call_symbols_preserved; eauto. apply senv_preserved.
-  econstructor; eauto.
-  unfold loc_external_result.
-  apply agree_set_other; auto. apply agree_set_pair; auto.
-
-- (* return *)
-  inv STACKS. simpl in *.
-  right. split. omega. split. auto.
-  rewrite <- ATPC in H5.
-  econstructor; eauto. congruence.
+  exploit Mach_Machblock_tail; eauto.
+  destruct 1.
+  eapply Asmblockgenproof.return_address_exists; eauto.
 Qed.
 
-Lemma transf_initial_states:
-  forall st1, Mach.initial_state prog st1 ->
-  exists st2, Asm.initial_state tprog st2 /\ match_states st1 st2.
-Proof.
-  intros. inversion H. unfold ge0 in *.
-  econstructor; split.
-  econstructor.
-  eapply (Genv.init_mem_transf_partial TRANSF); eauto.
-  replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero)
-     with (Vptr fb Ptrofs.zero).
-  econstructor; eauto.
-  constructor.
-  apply Mem.extends_refl.
-  split. auto. simpl. unfold Vnullptr; destruct Archi.ptr64; congruence.
-  intros. rewrite Regmap.gi. auto.
-  unfold Genv.symbol_address.
-  rewrite (match_program_main TRANSF).
-  rewrite symbols_preserved.
-  unfold ge; rewrite H1. auto.
-Qed.
 
-Lemma transf_final_states:
-  forall st1 st2 r,
-  match_states st1 st2 -> Mach.final_state st1 r -> Asm.final_state st2 r.
-Proof.
-  intros. inv H0. inv H. constructor. assumption.
-  compute in H1. inv H1.
-  generalize (preg_val _ _ _ R0 AG). rewrite H2. intros LD; inv LD. auto.
-Qed.
+Section PRESERVATION.
+
+Variable prog: Mach.program.
+Variable tprog: program.
+Hypothesis TRANSF: match_prog prog tprog.
+Let ge := Genv.globalenv prog.
+Let tge := Genv.globalenv tprog.
 
 Theorem transf_program_correct:
   forward_simulation (Mach.semantics return_address_offset prog) (Asm.semantics tprog).
 Proof.
-  eapply forward_simulation_star with (measure := measure).
-  apply senv_preserved.
-  eexact transf_initial_states.
-  eexact transf_final_states.
-  exact step_simulation.
+  unfold match_prog in TRANSF. simpl in TRANSF.
+  inv TRANSF. inv H. inv H1. inv H. inv H2. inv H.
+  eapply compose_forward_simulations. 
+  exploit Machblockgenproof.transf_program_correct; eauto.
+  unfold Machblockgenproof.inv_trans_rao. 
+  intros X; apply X.
+  eapply compose_forward_simulations. apply Asmblockgenproof.transf_program_correct; eauto.
+  apply Asm.transf_program_correct. eauto.
 Qed.
 
 End PRESERVATION.
+
+Instance TransfAsm: TransfLink match_prog := pass_match_link (compose_passes block_passes).
+
diff --git a/mppa_k1c/Machblock.v b/mppa_k1c/Machblock.v
new file mode 100644
index 00000000..44cec642
--- /dev/null
+++ b/mppa_k1c/Machblock.v
@@ -0,0 +1,355 @@
+Require Import Coqlib.
+Require Import Maps.
+Require Import AST.
+Require Import Integers.
+Require Import Values.
+Require Import Memory.
+Require Import Globalenvs.
+Require Import Events.
+Require Import Smallstep.
+Require Import Op.
+Require Import Locations.
+Require Import Conventions.
+Require Stacklayout.
+Require Import Mach.
+Require Import Linking.
+
+(** instructions "basiques" (ie non control-flow) *)
+Inductive basic_inst: Type :=
+  | MBgetstack: ptrofs -> typ -> mreg -> basic_inst
+  | MBsetstack: mreg -> ptrofs -> typ -> basic_inst
+  | MBgetparam: ptrofs -> typ -> mreg -> basic_inst
+  | MBop: operation -> list mreg -> mreg -> basic_inst
+  | MBload: memory_chunk -> addressing -> list mreg -> mreg -> basic_inst
+  | MBstore: memory_chunk -> addressing -> list mreg -> mreg -> basic_inst
+  .
+
+Definition bblock_body := list basic_inst.
+
+(** instructions de control flow *)
+Inductive control_flow_inst: Type :=
+  | MBcall: signature -> mreg + ident -> control_flow_inst
+  | MBtailcall: signature -> mreg + ident -> control_flow_inst
+  | MBbuiltin: external_function -> list (builtin_arg mreg) -> builtin_res mreg -> control_flow_inst
+  | MBgoto: label -> control_flow_inst
+  | MBcond: condition -> list mreg -> label -> control_flow_inst
+  | MBjumptable: mreg -> list label -> control_flow_inst
+  | MBreturn: control_flow_inst
+  .
+
+Record bblock := mk_bblock {
+  header: list label;
+  body:   bblock_body;
+  exit:   option control_flow_inst
+}.
+
+Lemma bblock_eq:
+  forall b1 b2,
+  header b1 = header b2 ->
+  body b1 = body b2 ->
+  exit b1 = exit b2 ->
+  b1 = b2.
+Proof.
+  intros. destruct b1. destruct b2.
+  simpl in *. subst. auto.
+Qed.
+
+Definition length_opt {A} (o: option A) : nat :=
+  match o with
+  | Some o => 1
+  | None => 0
+  end.
+
+Definition size (b:bblock): nat := (length (header b))+(length (body b))+(length_opt (exit b)).
+
+Lemma size_null b:
+  size b = 0%nat ->
+  header b = nil /\ body b = nil /\ exit b = None.
+Proof.
+  destruct b as [h b e]. simpl. unfold size. simpl.
+  intros H.
+  assert (length h = 0%nat) as Hh; [ omega |].
+  assert (length b = 0%nat) as Hb; [ omega |].
+  assert (length_opt e = 0%nat) as He; [ omega|].
+  repeat split.
+  destruct h; try (simpl in Hh; discriminate); auto.
+  destruct b; try (simpl in Hb; discriminate); auto.
+  destruct e; try (simpl in He; discriminate); auto.
+Qed.
+
+Definition code := list bblock.
+
+Record function: Type := mkfunction
+  { fn_sig: signature;
+    fn_code: code;
+    fn_stacksize: Z;
+    fn_link_ofs: ptrofs;
+    fn_retaddr_ofs: ptrofs }.
+
+Definition fundef := AST.fundef function.
+
+Definition program := AST.program fundef unit.
+
+Definition genv := Genv.t fundef unit.
+
+(*** sémantique ***)
+
+Lemma in_dec (lbl: label) (l: list label):  { List.In lbl l } + { ~(List.In lbl l) }.
+Proof.
+  apply List.in_dec.
+  apply Pos.eq_dec.
+Qed.
+
+Definition is_label (lbl: label) (bb: bblock) : bool :=
+  if in_dec lbl (header bb) then true else false.
+
+Lemma is_label_correct_true lbl bb:
+  List.In lbl (header bb) <-> is_label lbl bb = true. 
+Proof.
+  unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition.
+Qed.
+
+Lemma is_label_correct_false lbl bb:
+  ~(List.In lbl (header bb)) <-> is_label lbl bb = false. 
+Proof.
+  unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition.
+Qed.
+
+
+Local Open Scope nat_scope.
+
+Fixpoint find_label (lbl: label) (c: code) {struct c} : option code :=
+  match c with
+  | nil => None
+  | bb1 :: bbl => if is_label lbl bb1 then Some c else find_label lbl bbl
+  end.
+
+Section RELSEM.
+
+Variable rao:function -> code -> ptrofs -> Prop.
+Variable ge:genv.
+
+Definition find_function_ptr
+        (ge: genv) (ros: mreg + ident) (rs: regset) : option block :=
+  match ros with
+  | inl r =>
+      match rs r with
+      | Vptr b ofs => if Ptrofs.eq ofs Ptrofs.zero then Some b else None
+      | _ => None
+      end
+  | inr symb =>
+      Genv.find_symbol ge symb
+  end.
+
+(** Machblock execution states. *)
+
+Inductive stackframe: Type :=
+  | Stackframe:
+      forall (f: block)       (**r pointer to calling function *)
+             (sp: val)        (**r stack pointer in calling function *)
+             (retaddr: val)   (**r Asm return address in calling function *)
+             (c: code),       (**r program point in calling function *)
+      stackframe.
+
+Inductive state: Type :=
+  | State:
+      forall (stack: list stackframe)  (**r call stack *)
+             (f: block)                (**r pointer to current function *)
+             (sp: val)                 (**r stack pointer *)
+             (c: code)                 (**r current program point *)
+             (rs: regset)              (**r register state *)
+             (m: mem),                 (**r memory state *)
+      state
+  | Callstate:
+      forall (stack: list stackframe)  (**r call stack *)
+             (f: block)                (**r pointer to function to call *)
+             (rs: regset)              (**r register state *)
+             (m: mem),                 (**r memory state *)
+      state
+  | Returnstate:
+      forall (stack: list stackframe)  (**r call stack *)
+             (rs: regset)              (**r register state *)
+             (m: mem),                 (**r memory state *)
+      state.
+
+Definition parent_sp (s: list stackframe) : val :=
+  match s with
+  | nil => Vnullptr
+  | Stackframe f sp ra c :: s' => sp
+  end.
+
+Definition parent_ra (s: list stackframe) : val :=
+  match s with
+  | nil => Vnullptr
+  | Stackframe f sp ra c :: s' => ra
+  end.
+
+Inductive basic_step (s: list stackframe) (fb: block) (sp: val) (rs: regset) (m:mem): basic_inst -> regset -> mem -> Prop :=
+  | exec_MBgetstack:
+      forall ofs ty dst v,
+      load_stack m sp ty ofs = Some v ->
+      basic_step s fb sp rs m (MBgetstack ofs ty dst) (rs#dst <- v) m
+  | exec_MBsetstack:
+      forall src ofs ty m' rs',
+      store_stack m sp ty ofs (rs src) = Some m' ->
+      rs' = undef_regs (destroyed_by_setstack ty) rs ->
+      basic_step s fb sp rs m (MBsetstack src ofs ty) rs' m'
+  | exec_MBgetparam:
+      forall ofs ty dst v rs' f,
+      Genv.find_funct_ptr ge fb = Some (Internal f) ->
+      load_stack m sp Tptr f.(fn_link_ofs) = Some (parent_sp s) ->
+      load_stack m (parent_sp s) ty ofs = Some v ->
+      rs' = (rs # temp_for_parent_frame <- Vundef # dst <- v) ->
+      basic_step s fb sp rs m (MBgetparam ofs ty dst) rs' m
+  | exec_MBop:
+      forall op args v rs' res,
+      eval_operation ge sp op rs##args m = Some v ->
+      rs' = ((undef_regs (destroyed_by_op op) rs)#res <- v) ->
+      basic_step s fb sp rs m (MBop op args res) rs' m
+  | exec_MBload:
+      forall addr args a v rs' chunk dst,
+      eval_addressing ge sp addr rs##args = Some a ->
+      Mem.loadv chunk m a = Some v ->
+      rs' = ((undef_regs (destroyed_by_load chunk addr) rs)#dst <- v) ->
+      basic_step s fb sp rs m (MBload chunk addr args dst) rs' m
+  | exec_MBstore:
+      forall chunk addr args src m' a rs',
+      eval_addressing ge sp addr rs##args = Some a ->
+      Mem.storev chunk m a (rs src) = Some m' ->
+      rs' = undef_regs (destroyed_by_store chunk addr) rs ->
+      basic_step s fb sp rs m (MBstore chunk addr args src) rs' m'
+  .
+
+
+Inductive body_step (s: list stackframe) (f: block) (sp: val): bblock_body -> regset -> mem -> regset -> mem -> Prop :=
+   | exec_nil_body:
+       forall rs m,
+       body_step s f sp nil rs m rs m
+   | exec_cons_body:
+       forall rs m bi p rs' m' rs'' m'',
+       basic_step s f sp rs m bi rs' m' ->
+       body_step s f sp p rs' m' rs'' m'' ->
+       body_step s f sp (bi::p) rs m rs'' m''
+   .
+
+Inductive cfi_step: control_flow_inst -> state -> trace -> state -> Prop :=
+  | exec_MBcall:
+      forall s fb sp sig ros c b rs m f f' ra,
+      find_function_ptr ge ros rs = Some f' ->
+      Genv.find_funct_ptr ge fb = Some (Internal f) ->
+      rao f c ra ->
+      cfi_step (MBcall sig ros) (State s fb sp (b::c) rs m)
+        E0 (Callstate (Stackframe fb sp (Vptr fb ra) c :: s)
+                       f' rs m)
+  | exec_MBtailcall:
+      forall s fb stk soff sig ros c rs m f f' m',
+      find_function_ptr ge ros rs = Some f' ->
+      Genv.find_funct_ptr ge fb = Some (Internal f) ->
+      load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp s) ->
+      load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra s) ->
+      Mem.free m stk 0 f.(fn_stacksize) = Some m' ->
+      cfi_step (MBtailcall sig ros) (State s fb (Vptr stk soff) c rs m)
+        E0 (Callstate s f' rs m')
+  | exec_MBbuiltin:
+      forall s f sp rs m ef args res b c vargs t vres rs' m',
+      eval_builtin_args ge rs sp m args vargs ->
+      external_call ef ge vargs m t vres m' ->
+      rs' = set_res res vres (undef_regs (destroyed_by_builtin ef) rs) ->
+      cfi_step (MBbuiltin ef args res) (State s f sp (b :: c) rs m)
+         t (State s f sp c rs' m')
+  | exec_MBgoto:
+      forall s fb f sp lbl c rs m c',
+      Genv.find_funct_ptr ge fb = Some (Internal f) ->
+      find_label lbl f.(fn_code) = Some c' ->
+      cfi_step (MBgoto lbl) (State s fb sp c rs m)
+        E0 (State s fb sp c' rs m)
+  | exec_MBcond_true:
+      forall s fb f sp cond args lbl c rs m c' rs',
+      eval_condition cond rs##args m = Some true ->
+      Genv.find_funct_ptr ge fb = Some (Internal f) ->
+      find_label lbl f.(fn_code) = Some c' ->
+      rs' = undef_regs (destroyed_by_cond cond) rs ->
+      cfi_step (MBcond cond args lbl) (State s fb sp c rs m)
+        E0 (State s fb sp c' rs' m)
+  | exec_MBcond_false:
+      forall s f sp cond args lbl b c rs m rs',
+      eval_condition cond rs##args m = Some false ->
+      rs' = undef_regs (destroyed_by_cond cond) rs ->
+      cfi_step (MBcond cond args lbl) (State s f sp (b :: c) rs m)
+        E0 (State s f sp c rs' m)
+  | exec_MBjumptable:
+      forall s fb f sp arg tbl c rs m n lbl c' rs',
+      rs arg = Vint n ->
+      list_nth_z tbl (Int.unsigned n) = Some lbl ->
+      Genv.find_funct_ptr ge fb = Some (Internal f) ->
+      find_label lbl f.(fn_code) = Some c' ->
+      rs' = undef_regs destroyed_by_jumptable rs ->
+      cfi_step (MBjumptable arg tbl) (State s fb sp c rs m)
+        E0 (State s fb sp c' rs' m)
+  | exec_MBreturn:
+      forall s fb stk soff c rs m f m',
+      Genv.find_funct_ptr ge fb = Some (Internal f) ->
+      load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp s) ->
+      load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra s) ->
+      Mem.free m stk 0 f.(fn_stacksize) = Some m' ->
+      cfi_step MBreturn (State s fb (Vptr stk soff) c rs m)
+        E0 (Returnstate s rs m')
+  .
+
+Inductive exit_step: option control_flow_inst -> state -> trace -> state -> Prop :=
+  | exec_Some_exit:
+      forall ctl s t s',
+      cfi_step ctl s t s' ->
+      exit_step (Some ctl) s t s'
+  | exec_None_exit:
+      forall stk f sp b lb rs m,
+      exit_step None (State stk f sp (b::lb) rs m) E0 (State stk f sp lb rs m)
+  .
+
+Inductive step: state -> trace -> state -> Prop :=
+  | exec_bblock:
+      forall sf f sp bb c rs m rs' m' t s',
+        body_step sf f sp (body bb) rs m rs' m' ->
+        exit_step (exit bb) (State sf f sp (bb::c) rs' m') t s' ->
+        step (State sf f sp (bb::c) rs m) t s'
+  | exec_function_internal:
+      forall s fb rs m f m1 m2 m3 stk rs',
+      Genv.find_funct_ptr ge fb = Some (Internal f) ->
+      Mem.alloc m 0 f.(fn_stacksize) = (m1, stk) ->
+      let sp := Vptr stk Ptrofs.zero in
+      store_stack m1 sp Tptr f.(fn_link_ofs) (parent_sp s) = Some m2 ->
+      store_stack m2 sp Tptr f.(fn_retaddr_ofs) (parent_ra s) = Some m3 ->
+      rs' = undef_regs destroyed_at_function_entry rs ->
+      step (Callstate s fb rs m)
+        E0 (State s fb sp f.(fn_code) rs' m3)
+  | exec_function_external:
+      forall s fb rs m t rs' ef args res m',
+      Genv.find_funct_ptr ge fb = Some (External ef) ->
+      extcall_arguments rs m (parent_sp s) (ef_sig ef) args ->
+      external_call ef ge args m t res m' ->
+      rs' = set_pair (loc_result (ef_sig ef)) res rs ->
+      step (Callstate s fb rs m)
+         t (Returnstate s rs' m')
+  | exec_return:
+      forall s f sp ra c rs m,
+      step (Returnstate (Stackframe f sp ra c :: s) rs m)
+        E0 (State s f sp c rs m)
+  .
+
+End RELSEM.
+
+Inductive initial_state (p: program): state -> Prop :=
+  | initial_state_intro: forall fb m0,
+      let ge := Genv.globalenv p in
+      Genv.init_mem p = Some m0 ->
+      Genv.find_symbol ge p.(prog_main) = Some fb ->
+      initial_state p (Callstate nil fb (Regmap.init Vundef) m0).
+
+Inductive final_state: state -> int -> Prop :=
+  | final_state_intro: forall rs m r retcode,
+      loc_result signature_main = One r ->
+      rs r = Vint retcode ->
+      final_state (Returnstate nil rs m) retcode.
+
+Definition semantics (rao: function -> code -> ptrofs -> Prop) (p: program) :=
+  Semantics (step rao) (initial_state p) final_state (Genv.globalenv p).
diff --git a/mppa_k1c/Machblockgen.v b/mppa_k1c/Machblockgen.v
new file mode 100644
index 00000000..1d5555df
--- /dev/null
+++ b/mppa_k1c/Machblockgen.v
@@ -0,0 +1,578 @@
+Require Import Coqlib.
+Require Import Maps.
+Require Import AST.
+Require Import Integers.
+Require Import Values.
+Require Import Memory.
+Require Import Globalenvs.
+Require Import Events.
+Require Import Smallstep.
+Require Import Op.
+Require Import Locations.
+Require Import Conventions.
+Require Stacklayout.
+Require Import Mach.
+Require Import Linking.
+Require Import Machblock.
+
+
+Fixpoint to_bblock_header (c: Mach.code): list label * Mach.code :=
+  match c with
+  | (Mlabel l)::c' => 
+      let (h, c'') := to_bblock_header c' in
+      (l::h, c'')
+  | _ => (nil, c)
+  end.
+
+Definition to_basic_inst(i: Mach.instruction): option basic_inst :=
+  match i with
+  | Mgetstack ofs ty dst          => Some (MBgetstack ofs ty dst)
+  | Msetstack src ofs ty          => Some (MBsetstack src ofs ty)
+  | Mgetparam ofs ty dst          => Some (MBgetparam ofs ty dst)
+  | Mop       op args res         => Some (MBop       op args res)
+  | Mload     chunk addr args dst => Some (MBload     chunk addr args dst)
+  | Mstore    chunk addr args src => Some (MBstore    chunk addr args src)
+  | _ => None
+  end.
+
+Fixpoint to_bblock_body(c: Mach.code): bblock_body * Mach.code :=
+  match c with
+  | nil => (nil,nil)
+  | i::c' =>
+    match to_basic_inst i with
+    | Some bi =>
+       let (p,c'') := to_bblock_body c' in
+       (bi::p, c'')
+    | None => (nil, c)
+    end
+  end.
+
+
+Definition to_cfi (i: Mach.instruction): option control_flow_inst :=
+  match i with
+  | Mcall sig ros         => Some (MBcall sig ros)
+  | Mtailcall sig ros     => Some (MBtailcall sig ros)
+  | Mbuiltin ef args res  => Some (MBbuiltin ef args res)
+  | Mgoto lbl             => Some (MBgoto lbl)
+  | Mcond cond args lbl   => Some (MBcond cond args lbl)
+  | Mjumptable arg tbl    => Some (MBjumptable arg tbl)
+  | Mreturn               => Some (MBreturn)
+  | _ => None
+  end.
+
+Definition to_bblock_exit (c: Mach.code): option control_flow_inst * Mach.code :=
+  match c with
+  | nil => (None,nil)
+  | i::c' =>
+    match to_cfi i with
+    | Some bi as o => (o, c')
+    | None => (None, c)
+    end
+  end.
+
+Inductive code_nature: Set := IsEmpty | IsLabel | IsBasicInst | IsCFI.
+
+Definition get_code_nature (c: Mach.code): code_nature :=
+  match c with
+  | nil => IsEmpty
+  | (Mlabel _)::_ => IsLabel
+  | i::_ => match to_basic_inst i with
+         | Some _ => IsBasicInst
+         | None => IsCFI
+         end
+  end.
+
+Lemma cn_eqdec (cn1 cn2: code_nature): { cn1=cn2 } + {cn1 <> cn2}.
+Proof.
+  decide equality.
+Qed.
+
+Lemma get_code_nature_nil c: c<>nil -> get_code_nature c <> IsEmpty.
+Proof.
+  intros H. unfold get_code_nature.
+  destruct c; try (contradict H; auto; fail).
+  destruct i; discriminate.
+Qed.
+
+Lemma get_code_nature_empty c: get_code_nature c = IsEmpty -> c = nil.
+Proof.
+  intros H. destruct c; auto. exploit (get_code_nature_nil (i::c)); discriminate || auto.
+  intro F. contradict F.
+Qed.
+
+Lemma to_bblock_header_noLabel c:
+  get_code_nature c <> IsLabel ->
+  to_bblock_header c = (nil, c).
+Proof.
+  intros H. destruct c as [|i c]; auto.
+  destruct i; simpl; auto.
+  contradict H; simpl; auto.
+Qed.
+
+Lemma to_bblock_header_wfe c:
+  forall h c0,
+  to_bblock_header c = (h, c0) ->
+  (length c >= length c0)%nat.
+Proof.
+  induction c as [ |i c]; simpl; intros h c' H.
+  - inversion H; subst; clear H; simpl; auto.
+  - destruct i; try (inversion H; subst; simpl; auto; fail).
+    remember (to_bblock_header c) as bhc; destruct bhc as [h0 c0].
+    inversion H; subst.
+    lapply (IHc h0 c'); auto.
+Qed.
+
+Lemma to_bblock_header_wf c b c0:
+  get_code_nature c = IsLabel ->
+  to_bblock_header c = (b, c0) ->
+  (length c > length c0)%nat.
+Proof.
+  intros H1 H2; destruct c; [ contradict H1; simpl; discriminate | ].
+  destruct i; try discriminate.
+  simpl in H2.
+  remember (to_bblock_header c) as bh; destruct bh as [h c''].
+  inversion H2; subst.
+  exploit to_bblock_header_wfe; eauto.
+  simpl; omega.
+Qed.
+
+Lemma to_bblock_body_noBasic c:
+  get_code_nature c <> IsBasicInst ->
+  to_bblock_body c = (nil, c).
+Proof.
+  intros H. destruct c as [|i c]; simpl; auto.
+  destruct i; simpl; auto.
+  all: contradict H; simpl; auto.
+Qed.
+
+Lemma to_bblock_body_wfe c b c0:
+  to_bblock_body c = (b, c0) ->
+  (length c >= length c0)%nat.
+Proof.
+  generalize b c0; clear b c0.
+  induction c as [|i c].
+  - intros b c0 H. simpl in H. inversion H; subst; auto.
+  - intros b c0 H. simpl in H. destruct (to_basic_inst i).
+    + remember (to_bblock_body c) as tbbc; destruct tbbc as [p c''].
+      exploit (IHc p c''); auto. inversion H; subst; simpl; omega.
+    + inversion H; subst; auto.
+Qed.
+
+(** Attempt to eliminate cons_to_bblock_body *)
+(*
+Lemma to_bblock_body_basic c:
+  get_code_nature c = IsBasicInst ->
+  exists i bi b c',
+     to_basic_inst i = Some bi
+  /\ c = i :: c'
+  /\ to_bblock_body c = (bi::b, snd (to_bblock_body c')).
+Proof.
+  intros H.
+  destruct c as [|i c]; try (contradict H; simpl; discriminate).
+  destruct i eqn:I; try (contradict H; simpl; discriminate).
+  all: simpl; destruct (to_bblock_body c)  as [p c''] eqn:TBBC; repeat (eapply ex_intro); (repeat split);
+    simpl; eauto; rewrite TBBC; simpl; eauto.
+Qed.
+
+Lemma to_bblock_body_wf c b c0:
+  get_code_nature c = IsBasicInst ->
+  to_bblock_body c = (b, c0) ->
+  (length c > length c0)%nat.
+Proof.
+  intros H1 H2; exploit to_bblock_body_basic; eauto.
+  intros X. destruct X as (i & bi & b' & c' & X1 & X2 & X3).
+  exploit to_bblock_body_wfe. eauto. subst. simpl.
+  rewrite X3 in H2. inversion H2; clear H2; subst.
+  simpl; omega.
+Qed.
+*)
+
+Inductive cons_to_bblock_body c0: Mach.code -> bblock_body -> Prop :=
+  Cons_to_bbloc_body i bi c' b':
+    to_basic_inst i = Some bi
+    -> to_bblock_body c' = (b', c0)
+    -> cons_to_bblock_body c0 (i::c') (bi::b').
+
+Lemma to_bblock_body_IsBasicInst c b c0:
+  get_code_nature c = IsBasicInst ->
+  to_bblock_body c = (b, c0) ->
+  cons_to_bblock_body c0 c b.
+Proof.
+  intros H1 H2. destruct c; [ contradict H1; simpl; discriminate | ].
+  remember (to_basic_inst i) as tbii. destruct tbii.
+  - simpl in H2. rewrite <- Heqtbii in H2.
+    remember (to_bblock_body c) as tbbc. destruct tbbc as [p1 c1].
+    inversion H2. subst. eapply Cons_to_bbloc_body; eauto.
+  - destruct i; try discriminate.
+Qed.
+
+Lemma to_bblock_body_wf c b c0:
+  get_code_nature c = IsBasicInst ->
+  to_bblock_body c = (b, c0) ->
+  (length c > length c0)%nat.
+Proof.
+  intros H1 H2; exploit to_bblock_body_IsBasicInst; eauto.
+  intros X. destruct X.
+  exploit to_bblock_body_wfe; eauto. subst. simpl.
+  simpl; omega.
+Qed.
+
+Lemma to_bblock_exit_noCFI c:
+  get_code_nature c <> IsCFI ->
+  to_bblock_exit c = (None, c).
+Proof.
+  intros H. destruct c as [|i c]; simpl; auto.
+  destruct i; simpl; auto.
+  all: contradict H; simpl; auto.
+Qed.
+
+Lemma to_bblock_exit_wf c b c0:
+  get_code_nature c = IsCFI ->
+  to_bblock_exit c = (b, c0) ->
+  (length c > length c0)%nat.
+Proof.
+  intros H1 H2. destruct c as [|i c]; try discriminate.
+  destruct i; try discriminate;
+  unfold to_bblock_header in H2; inversion H2; auto.
+Qed.
+
+Lemma to_bblock_exit_wfe c b c0:
+  to_bblock_exit c = (b, c0) ->
+  (length c >= length c0)%nat.
+Proof.
+  intros H. destruct c as [|i c].
+  - simpl in H. inversion H; subst; clear H; auto.
+  - destruct i; try ( simpl in H; inversion H; subst; clear H; auto ).
+    all: simpl; auto.
+Qed.
+
+Definition to_bblock(c: Mach.code): bblock * Mach.code :=
+  let (h,c0) := to_bblock_header c in
+  let (bdy, c1) := to_bblock_body c0 in
+  let (ext, c2) := to_bblock_exit c1 in
+  ({| header := h; body := bdy; exit := ext |}, c2)
+  .
+
+Lemma to_bblock_acc_label c l b c':
+  to_bblock c = (b, c') ->
+  to_bblock (Mlabel l :: c) = ({| header := l::(header b); body := (body b); exit := (exit b) |}, c').
+Proof.
+  unfold to_bblock; simpl.
+  remember (to_bblock_header c) as bhc; destruct bhc as [h c0].
+  remember (to_bblock_body c0) as bbc; destruct bbc as [bdy c1].
+  remember (to_bblock_exit c1) as bbc; destruct bbc as [ext c2].
+  intros H; inversion H; subst; clear H; simpl; auto.
+Qed.
+
+Lemma to_bblock_basic_then_label i c bi:
+  get_code_nature (i::c) = IsBasicInst ->
+  get_code_nature c = IsLabel ->
+  to_basic_inst i = Some bi ->
+  fst (to_bblock (i::c)) = {| header := nil; body := bi::nil; exit := None |}.
+Proof.
+  intros H1 H2 H3.
+  destruct c as [|i' c]; try (contradict H1; simpl; discriminate).
+  destruct i'; try (contradict H1; simpl; discriminate).
+  destruct i; simpl in *; inversion H3; subst; auto.
+Qed.
+
+Lemma to_bblock_CFI i c cfi:
+  get_code_nature (i::c) = IsCFI ->
+  to_cfi i = Some cfi ->
+  fst (to_bblock (i::c)) = {| header := nil; body := nil; exit := Some cfi |}.
+Proof.
+  intros H1 H2.
+  destruct i; try discriminate.
+  all: subst; rewrite <- H2; simpl; auto.
+Qed.
+
+Lemma to_bblock_noLabel c:
+  get_code_nature c <> IsLabel ->
+  fst (to_bblock c) = {|
+    header := nil;
+    body := body (fst (to_bblock c));
+    exit := exit (fst (to_bblock c))
+  |}.
+Proof.
+  intros H.
+  destruct c as [|i c]; simpl; auto.
+  apply bblock_eq; simpl;
+  destruct i; (
+      try (
+        remember (to_bblock _) as bb;
+        unfold to_bblock in *;
+        remember (to_bblock_header _) as tbh;
+        destruct tbh;
+        destruct (to_bblock_body _);
+        destruct (to_bblock_exit _);
+        subst; simpl; inversion Heqtbh; auto; fail
+      )
+    || contradict H; simpl; auto ).
+Qed.
+
+Lemma to_bblock_body_nil c c':
+  to_bblock_body c = (nil, c') ->
+  c = c'.
+Proof.
+  intros H.
+  destruct c as [|i c]; [ simpl in *; inversion H; auto |].
+  destruct i; try ( simpl in *; remember (to_bblock_body c) as tbc; destruct tbc as [p c'']; inversion H ).
+  all: auto.
+Qed.
+
+Lemma to_bblock_exit_nil c c':
+  to_bblock_exit c = (None, c') ->
+  c = c'.
+Proof.
+  intros H.
+  destruct c as [|i c]; [ simpl in *; inversion H; auto |].
+  destruct i; try ( simpl in *; remember (to_bblock_exit c) as tbe; destruct tbe as [p c'']; inversion H ).
+  all: auto.
+Qed.
+
+Lemma to_bblock_label b l c c':
+  to_bblock (Mlabel l :: c) = (b, c') ->
+  (header b) = l::(tail (header b)) /\ to_bblock c = ({| header:=tail (header b); body := body b; exit := exit b |}, c').
+Proof.
+  unfold to_bblock; simpl.
+  remember (to_bblock_header c) as bhc; destruct bhc as [h c0].
+  remember (to_bblock_body c0) as bbc; destruct bbc as [bdy c1].
+  remember (to_bblock_exit c1) as bbc; destruct bbc as [ext c2].
+  intros H; inversion H; subst; clear H; simpl; auto.
+Qed.
+
+Lemma to_bblock_basic c i bi:
+  get_code_nature (i::c) = IsBasicInst ->
+  to_basic_inst i = Some bi ->
+  get_code_nature c <> IsLabel ->
+  fst (to_bblock (i::c)) = {|
+    header := nil;
+    body := bi :: body (fst (to_bblock c));
+    exit := exit (fst (to_bblock c))
+  |}.
+Proof.
+  intros.
+  destruct c; try (destruct i; inversion H0; subst; simpl; auto; fail).
+  apply bblock_eq; simpl.
+(* header *)
+  + destruct i; simpl; auto; (
+      exploit to_bblock_noLabel; [rewrite H; discriminate | intro; rewrite H2; simpl; auto]).
+(* body *)
+(* FIXME - the proof takes some time to prove.. N² complexity :( *)
+  + unfold to_bblock.
+    remember (to_bblock_header _) as tbh; destruct tbh.
+    remember (to_bblock_body _) as tbb; destruct tbb.
+    remember (to_bblock_exit _) as tbe; destruct tbe.
+    simpl.
+    destruct i; destruct i0.
+    all: try (simpl in H1; contradiction).
+    all: try discriminate.
+    all: try (
+    simpl in Heqtbh; inversion Heqtbh; clear Heqtbh; subst;
+    simpl in Heqtbb; remember (to_bblock_body c) as tbbc; destruct tbbc;
+    inversion Heqtbb; clear Heqtbb; subst; simpl in *; clear H H1;
+    inversion H0; clear H0; subst; destruct (to_bblock_body c);
+    inversion Heqtbbc; clear Heqtbbc; subst;
+    destruct (to_bblock_exit c1); simpl; auto; fail).
+(* exit *)
+  + unfold to_bblock.
+    remember (to_bblock_header _) as tbh; destruct tbh.
+    remember (to_bblock_body _) as tbb; destruct tbb.
+    remember (to_bblock_exit _) as tbe; destruct tbe.
+    simpl.
+    destruct i; destruct i0.
+    all: try (simpl in H1; contradiction).
+    all: try discriminate.
+    all: try (
+    simpl in Heqtbh; inversion Heqtbh; clear Heqtbh; subst;
+    simpl in Heqtbb; remember (to_bblock_body c) as tbbc; destruct tbbc; 
+    inversion Heqtbb; clear Heqtbb; subst; simpl in *; clear H H1;
+    inversion H0; clear H0; subst; destruct (to_bblock_body c) eqn:TBBC;
+    inversion Heqtbbc; clear Heqtbbc; subst;
+    destruct (to_bblock_exit c1) eqn:TBBE; simpl;
+    inversion Heqtbe; clear Heqtbe; subst; auto; fail).
+Qed.
+
+Lemma to_bblock_size_single_label c i:
+  get_code_nature (i::c) = IsLabel ->
+  size (fst (to_bblock (i::c))) = Datatypes.S (size (fst (to_bblock c))).
+Proof.
+  intros H.
+  destruct i; try discriminate.
+  remember (to_bblock c) as bl. destruct bl as [b c'].
+  erewrite to_bblock_acc_label; eauto.
+  unfold size; simpl.
+  auto.
+Qed.
+
+Lemma to_bblock_size_label_neqz c:
+  get_code_nature c = IsLabel ->
+  size (fst (to_bblock c)) <> 0%nat.
+Proof.
+  destruct c as [ |i c]; try discriminate.
+  intros; rewrite to_bblock_size_single_label; auto.
+Qed.
+
+Lemma to_bblock_size_basic_neqz c:
+  get_code_nature c = IsBasicInst ->
+  size (fst (to_bblock c)) <> 0%nat.
+Proof.
+  intros H. destruct c as [|i c]; try (contradict H; auto; simpl; discriminate).
+  destruct i; try (contradict H; simpl; discriminate);
+  (
+    destruct (get_code_nature c) eqn:gcnc;
+    (* Case gcnc is not IsLabel *)
+    try (erewrite to_bblock_basic; eauto; [
+        unfold size; simpl; auto
+      | simpl; auto
+      | rewrite gcnc; discriminate
+    ]);
+    erewrite to_bblock_basic_then_label; eauto; [
+        unfold size; simpl; auto
+      | simpl; auto
+    ]
+  ).
+Qed.
+
+Lemma to_bblock_size_cfi_neqz c:
+  get_code_nature c = IsCFI ->
+  size (fst (to_bblock c)) <> 0%nat.
+Proof.
+  intros H. destruct c as [|i c]; try (contradict H; auto; simpl; discriminate).
+  destruct i; discriminate.
+Qed.
+
+Lemma to_bblock_size_single_basic c i:
+  get_code_nature (i::c) = IsBasicInst ->
+  get_code_nature c <> IsLabel ->
+  size (fst (to_bblock (i::c))) = Datatypes.S (size (fst (to_bblock c))).
+Proof.
+  intros.
+  destruct i; try (contradict H; simpl; discriminate); try (
+    (exploit to_bblock_basic; eauto);
+      [remember (to_basic_inst _) as tbi; destruct tbi; eauto |];
+    intro; rewrite H1; unfold size; simpl;
+    assert ((length (header (fst (to_bblock c)))) = 0%nat);
+      exploit to_bblock_noLabel; eauto; intro; rewrite H2; simpl; auto;
+    rewrite H2; auto
+  ).
+Qed.
+
+Lemma to_bblock_wf c b c0:
+  c <> nil ->
+  to_bblock c = (b, c0) ->
+  (length c > length c0)%nat.
+Proof.
+  intro H; lapply (get_code_nature_nil c); eauto.
+  intro H'; remember (get_code_nature c) as gcn.
+  unfold to_bblock.
+  remember (to_bblock_header c) as p1; eauto.
+  destruct p1 as [h c1].
+  intro H0.
+  destruct gcn.
+  - contradict H'; auto.
+  - exploit to_bblock_header_wf; eauto.
+    remember (to_bblock_body c1) as p2; eauto.
+    destruct p2 as [h2 c2].
+    exploit to_bblock_body_wfe; eauto.
+    remember (to_bblock_exit c2) as p3; eauto.
+    destruct p3 as [h3 c3].
+    exploit to_bblock_exit_wfe; eauto.
+    inversion H0. omega.
+  - exploit to_bblock_header_noLabel; eauto. rewrite <- Heqgcn. discriminate.
+    intro. rewrite H1 in Heqp1. inversion Heqp1. clear Heqp1. subst.
+    remember (to_bblock_body c) as p2; eauto.
+    destruct p2 as [h2 c2].
+    exploit to_bblock_body_wf; eauto.
+    remember (to_bblock_exit c2) as p3; eauto.
+    destruct p3 as [h3 c3].
+    exploit to_bblock_exit_wfe; eauto.
+    inversion H0. omega.
+  - exploit to_bblock_header_noLabel; eauto. rewrite <- Heqgcn. discriminate.
+    intro. rewrite H1 in Heqp1. inversion Heqp1; clear Heqp1; subst.
+    remember (to_bblock_body c) as p2; eauto.
+    destruct p2 as [h2 c2].
+    exploit (to_bblock_body_noBasic c); eauto. rewrite <- Heqgcn. discriminate.
+    intros H2; rewrite H2 in Heqp2; inversion Heqp2; clear Heqp2; subst.
+    remember (to_bblock_exit c) as p3; eauto.
+    destruct p3 as [h3 c3].
+    exploit (to_bblock_exit_wf c h3 c3); eauto.
+    inversion H0. omega.
+Qed.
+
+Lemma to_bblock_nonil i c0:
+  size (fst (to_bblock (i :: c0))) <> 0%nat.
+Proof.
+  intros H. remember (i::c0) as c. remember (get_code_nature c) as gcnc. destruct gcnc.
+  - contradict Heqgcnc. subst. simpl. destruct i; discriminate.
+  - eapply to_bblock_size_label_neqz; eauto.
+  - eapply to_bblock_size_basic_neqz; eauto.
+  - eapply to_bblock_size_cfi_neqz; eauto.
+Qed.
+
+Function trans_code (c: Mach.code) { measure length c }: code :=
+  match c with
+  | nil => nil
+  | _ =>
+     let (b, c0) := to_bblock c in
+     b::(trans_code c0)
+  end.
+Proof.
+  intros; eapply to_bblock_wf; eauto. discriminate.
+Qed.
+
+Lemma trans_code_nonil c:
+  c <> nil -> trans_code c <> nil.
+Proof.
+  intros H.
+  induction c, (trans_code c) using trans_code_ind; simpl; auto. discriminate.
+Qed.
+
+Lemma trans_code_step c b lb0 hb c1 bb c2 eb c3:
+  trans_code c = b :: lb0 ->
+  to_bblock_header c = (hb, c1) ->
+  to_bblock_body c1 = (bb, c2) ->
+  to_bblock_exit c2 = (eb, c3) ->
+  hb = header b /\ bb = body b /\ eb = exit b /\ trans_code c3 = lb0.
+Proof.
+  intros.
+  induction c, (trans_code c) using trans_code_ind. discriminate. clear IHc0.
+  subst. destruct _x as [|i c]; try (contradict y; auto; fail).
+  inversion H; subst. clear H. unfold to_bblock in e0.
+  remember (to_bblock_header (i::c)) as hd. destruct hd as [hb' c1'].
+  remember (to_bblock_body c1') as bd. destruct bd as [bb' c2'].
+  remember (to_bblock_exit c2') as be. destruct be as [eb' c3'].
+  inversion e0. simpl.
+  inversion H0. subst.
+  rewrite <- Heqbd in H1. inversion H1. subst.
+  rewrite <- Heqbe in H2. inversion H2. subst.
+  auto.
+Qed.
+
+Lemma trans_code_cfi i c cfi:
+  to_cfi i = Some cfi ->
+  trans_code (i :: c) = {| header := nil ; body := nil ; exit := Some cfi |} :: trans_code c.
+Proof.
+  intros. rewrite trans_code_equation. remember (to_bblock _) as tb; destruct tb as [b c0].
+  destruct i; try (contradict H; discriminate).
+  all: unfold to_bblock in Heqtb; remember (to_bblock_header _) as tbh; destruct tbh as [h c0'];
+      remember (to_bblock_body c0') as tbb; destruct tbb as [bdy c1'];
+      remember (to_bblock_exit c1') as tbe; destruct tbe as [ext c2]; simpl in *;
+      inversion Heqtbh; subst; inversion Heqtbb; subst; inversion Heqtbe; subst;
+      inversion Heqtb; subst; rewrite H; auto.
+Qed.
+
+(* à finir pour passer des Mach.function au function, etc. *)
+Definition transf_function (f: Mach.function) : function :=
+  {| fn_sig:=Mach.fn_sig f;
+     fn_code:=trans_code (Mach.fn_code f);
+     fn_stacksize := Mach.fn_stacksize f;
+     fn_link_ofs := Mach.fn_link_ofs f;
+     fn_retaddr_ofs := Mach.fn_retaddr_ofs f
+ |}.
+
+Definition transf_fundef (f: Mach.fundef) : fundef :=
+  transf_fundef transf_function f.
+
+Definition transf_program (src: Mach.program) : program :=
+  transform_program transf_fundef src.
diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v
new file mode 100644
index 00000000..62c1e0ed
--- /dev/null
+++ b/mppa_k1c/Machblockgenproof.v
@@ -0,0 +1,629 @@
+Require Import Coqlib.
+Require Import Maps.
+Require Import AST.
+Require Import Integers.
+Require Import Values.
+Require Import Memory.
+Require Import Globalenvs.
+Require Import Events.
+Require Import Smallstep.
+Require Import Op.
+Require Import Locations.
+Require Import Conventions.
+Require Stacklayout.
+Require Import Mach.
+Require Import Linking.
+Require Import Machblock.
+Require Import Machblockgen.
+Require Import ForwardSimulationBlock.
+
+Definition inv_trans_rao (rao: function -> code -> ptrofs -> Prop) (f: Mach.function) (c: Mach.code) :=
+  rao (transf_function f) (trans_code c).
+
+Definition match_prog (p: Mach.program) (tp: Machblock.program) :=
+  match_program (fun _ f tf => tf = transf_fundef f) eq p tp.
+
+Lemma transf_program_match: forall p tp, transf_program p = tp -> match_prog p tp.
+Proof.
+  intros. rewrite <- H. eapply match_transform_program; eauto.
+Qed.
+
+Definition trans_stackframe (msf: Mach.stackframe) : stackframe :=
+  match msf with
+  | Mach.Stackframe f sp retaddr c => Stackframe f sp retaddr (trans_code c)
+  end.
+
+Fixpoint trans_stack (mst: list Mach.stackframe) : list stackframe :=
+  match mst with
+  | nil => nil
+  | msf :: mst0 => (trans_stackframe msf) :: (trans_stack mst0)
+  end.
+
+Definition trans_state (ms: Mach.state) : state :=
+  match ms with
+  | Mach.State        s f sp c rs m => State        (trans_stack s) f sp (trans_code c) rs m
+  | Mach.Callstate    s f rs m      => Callstate    (trans_stack s) f rs m
+  | Mach.Returnstate  s rs m        => Returnstate  (trans_stack s) rs m
+  end.
+
+Section PRESERVATION.
+
+Local Open Scope nat_scope.
+
+Variable prog: Mach.program.
+Variable tprog: Machblock.program.
+Hypothesis TRANSF: match_prog prog tprog.
+Let ge := Genv.globalenv prog.
+Let tge := Genv.globalenv tprog.
+
+
+Variable rao: function -> code -> ptrofs -> Prop.
+
+Definition match_states: Mach.state -> state -> Prop 
+  := ForwardSimulationBlock.match_states (Mach.semantics (inv_trans_rao rao) prog) (Machblock.semantics rao tprog) trans_state.
+
+Lemma match_states_trans_state s1: match_states s1 (trans_state s1).
+Proof.
+  apply match_states_trans_state.
+Qed.
+
+Local Hint Resolve match_states_trans_state.
+
+Lemma symbols_preserved:
+  forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
+Proof (Genv.find_symbol_match TRANSF).
+
+Lemma senv_preserved:
+  Senv.equiv ge tge.
+Proof (Genv.senv_match TRANSF).
+
+Lemma init_mem_preserved:
+  forall m,
+  Genv.init_mem prog = Some m ->
+  Genv.init_mem tprog = Some m.
+Proof (Genv.init_mem_transf TRANSF).
+
+Lemma prog_main_preserved:
+  prog_main tprog = prog_main prog.
+Proof (match_program_main TRANSF).
+
+Lemma functions_translated:
+  forall b f,
+  Genv.find_funct_ptr ge b = Some f ->
+  exists tf, Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = tf.
+Proof.
+  intros.
+  exploit (Genv.find_funct_ptr_match TRANSF); eauto. intro.
+  destruct H0 as (cunit & tf & A & B & C).
+  eapply ex_intro. intuition; eauto. subst. eapply A.
+Qed.
+
+Lemma find_function_ptr_same:
+  forall s rs,
+  Mach.find_function_ptr ge s rs = find_function_ptr tge s rs.
+Proof.
+  intros. unfold Mach.find_function_ptr. unfold find_function_ptr.
+  destruct s; auto.
+  rewrite symbols_preserved; auto.
+Qed.
+
+Lemma find_funct_ptr_same:
+  forall f f0,
+  Genv.find_funct_ptr ge f = Some (Internal f0) ->
+  Genv.find_funct_ptr tge f = Some (Internal (transf_function f0)).
+Proof.
+  intros. exploit (Genv.find_funct_ptr_transf TRANSF); eauto.
+Qed.
+
+Lemma find_funct_ptr_same_external:
+  forall f f0,
+  Genv.find_funct_ptr ge f = Some (External f0) ->
+  Genv.find_funct_ptr tge f = Some (External f0).
+Proof.
+  intros. exploit (Genv.find_funct_ptr_transf TRANSF); eauto.
+Qed.
+
+Lemma parent_sp_preserved:
+  forall s,
+  Mach.parent_sp s = parent_sp (trans_stack s).
+Proof.
+  unfold parent_sp. unfold Mach.parent_sp. destruct s; simpl; auto.
+  unfold trans_stackframe. destruct s; simpl; auto.
+Qed.
+
+Lemma parent_ra_preserved:
+  forall s,
+  Mach.parent_ra s = parent_ra (trans_stack s).
+Proof.
+  unfold parent_ra. unfold Mach.parent_ra. destruct s; simpl; auto.
+  unfold trans_stackframe. destruct s; simpl; auto.
+Qed.
+
+Lemma external_call_preserved:
+  forall ef args m t res m',
+  external_call ef ge args m t res m' ->
+  external_call ef tge args m t res m'.
+Proof.
+  intros. eapply external_call_symbols_preserved; eauto.
+  apply senv_preserved.
+Qed.
+
+Lemma Mach_find_label_split l i c c':
+  Mach.find_label l (i :: c) = Some c' ->
+   (i=Mlabel l /\ c' = c) \/ (i <> Mlabel l /\ Mach.find_label l c = Some c').
+Proof.
+  intros H.
+  destruct i; try (constructor 2; split; auto; discriminate ).
+  destruct (peq l0 l) as [P|P].
+  - constructor. subst l0; split; auto.
+    revert H. unfold Mach.find_label. simpl. rewrite peq_true.
+    intros H; injection H; auto.
+  - constructor 2. split.
+    + intro F. injection F. intros. contradict P; auto.
+    + revert H. unfold Mach.find_label. simpl. rewrite peq_false; auto.
+Qed.
+
+
+Definition concat (h: list label) (c: code): code :=
+  match c with
+  | nil =>  {| header := h; body := nil; exit := None |}::nil
+  | b::c' => {| header := h ++ (header b); body := body b; exit := exit b |}::c'
+  end.
+
+Lemma to_bblock_start_label i c l b c0: 
+  (b, c0) = to_bblock (i :: c)
+  -> In l (header b)
+  -> i <> Mlabel l
+  -> exists l2, i=Mlabel l2.
+Proof.
+   unfold to_bblock.
+   remember (to_bblock_header _) as bh; destruct bh as [h c1].
+   remember (to_bblock_body _) as bb; destruct bb as [bdy c2].
+   remember (to_bblock_exit _) as be; destruct be as [ext c3].
+   intros H; inversion H; subst; clear H; simpl.
+   destruct i; try (simpl in Heqbh; inversion Heqbh; subst; clear Heqbh; simpl; intuition eauto).
+Qed.
+
+Lemma find_label_stop c:
+ forall l b c0 c',
+   (b, c0) = to_bblock c
+ -> Mach.find_label l c = Some c'
+ -> In l (header b)
+ -> exists h, In l h /\ Some (b :: trans_code c0) = Some (concat h (trans_code c')).
+Proof.
+  induction c as [ |i c].
+  - simpl; intros; discriminate.
+  - intros l b c0 c' H H1 H2.
+    exploit Mach_find_label_split; eauto; clear H1.
+    intros [(X1 & X2) | (X1 & X2)].
+    * subst. exploit to_bblock_label; eauto. clear H.
+      intros (H3 & H4). constructor 1 with (x:=l::nil); simpl; intuition auto.
+      symmetry.
+      rewrite trans_code_equation.
+      destruct c as [ |i c].
+      + unfold to_bblock in H4; simpl in H4.
+        injection H4. clear H4; intros H4 H H0 H1; subst. simpl.
+        rewrite trans_code_equation; simpl.
+        rewrite <- H1 in H3; clear H1.
+        destruct b as [h b e]; simpl in * |- *; subst; auto.
+      + rewrite H4; clear H4; simpl. rewrite <- H3; clear H3.
+        destruct b; simpl; auto.
+    * exploit to_bblock_start_label; eauto.
+      intros (l' & H'). subst.
+      assert (X: l' <> l). { intro Z; subst; destruct X1; auto. }
+      clear X1.
+      exploit to_bblock_label; eauto. clear H.
+      intros (H3 & H4).
+      exploit IHc; eauto. { simpl. rewrite H3 in H2; simpl in H2. destruct H2; subst; tauto. }
+      intros (h' & H5 & H6).
+      constructor 1 with (x:=l'::h'); simpl; intuition auto.
+      destruct b as [h b e]; simpl in * |- *; subst.
+      remember (tl h) as th. subst h.
+      remember (trans_code c') as tcc'.
+      rewrite trans_code_equation in Heqtcc'.
+      destruct c'; subst; simpl in * |- *. 
+      + inversion H6; subst; auto.
+      + destruct (to_bblock (i :: c')) as [b1 c1]. simpl in * |- *.
+        inversion H6; subst; auto.
+Qed.
+
+Lemma to_bblock_header_find_label c l: forall c1 h c',
+  to_bblock_header c = (h, c1)
+  -> Mach.find_label l c = Some c'
+  -> ~ In l h
+  -> Mach.find_label l c = Mach.find_label l c1.
+Proof.
+  induction c as [|i  c]; simpl; auto.
+  - intros; discriminate.
+  - destruct i;
+    try (simpl; intros c1 h c' H1 H2; inversion H1; subst; clear H1; intros; apply refl_equal).
+    remember (to_bblock_header c) as tbhc. destruct tbhc as [h2 c2].
+    intros h c1 c' H1; inversion H1; subst; clear H1.
+    simpl. destruct (peq _ _).
+    + subst; tauto.
+    + intros H1 H2; erewrite IHc; eauto.
+Qed.
+
+Lemma to_bblock_body_find_label c1 l: forall c2 bdy,
+  (bdy, c2) = to_bblock_body c1 ->
+  Mach.find_label l c1 = Mach.find_label l c2.
+Proof.
+  induction c1 as [|i c1].
+  - intros bdy0 c0 H. simpl in H. inversion H; subst; clear H. auto.
+  - intros bdy' c2' H. simpl in H. destruct i; try (
+      simpl in H; remember (to_bblock_body c1) as tbb; destruct tbb as [p c''];
+      inversion H; subst; clear H; simpl; erewrite IHc1; eauto; fail).
+Qed.
+
+Lemma to_bblock_exit_find_label c1 l c2 ext:
+ (ext, c2) = to_bblock_exit c1
+ -> Mach.find_label l c1 = Mach.find_label l c2.
+Proof.
+  intros H. destruct c1 as [|i c1].
+  - simpl in H. inversion H; subst; clear H. auto.
+  - destruct i; try (
+      simpl in H; inversion H; subst; clear H; auto; fail).
+Qed.
+
+Lemma find_label_transcode_preserved:
+  forall l c c',
+  Mach.find_label l c = Some c' ->
+  exists h, In l h /\ find_label l (trans_code c) = Some (concat h (trans_code c')).
+Proof.
+  intros l c; induction c, (trans_code c) using trans_code_ind.
+  - intros c' H; inversion H.
+  - intros c' H. subst _x. destruct c as [| i c]; try tauto.
+   unfold to_bblock in * |-.
+   remember (to_bblock_header _) as bh; destruct bh as [h c1].
+   remember (to_bblock_body _) as bb; destruct bb as [bdy c2].
+   remember (to_bblock_exit _) as be; destruct be as [ext c3].
+   simpl; injection e0; intros; subst; clear e0.
+   unfold is_label; simpl; destruct (in_dec l h) as [Y|Y].
+   + clear IHc0.
+     eapply find_label_stop; eauto.
+     unfold to_bblock.
+     rewrite <- Heqbh, <- Heqbb, <- Heqbe. 
+     auto.
+   + exploit IHc0; eauto. clear IHc0.
+     rewrite <- H.
+     erewrite (to_bblock_header_find_label (i::c) l c1); eauto.
+     erewrite (to_bblock_body_find_label c1 l c2); eauto.
+     erewrite (to_bblock_exit_find_label c2 l c0); eauto.
+Qed.
+
+
+Lemma find_label_preserved:
+  forall l f c,
+  Mach.find_label l (Mach.fn_code f) = Some c ->
+  exists h, In l h /\ find_label l (fn_code (transf_function f)) = Some (concat h (trans_code c)).
+Proof.
+  intros. cutrewrite ((fn_code (transf_function f)) = trans_code (Mach.fn_code f)); eauto.
+  apply find_label_transcode_preserved; auto.
+Qed.
+
+Lemma mem_free_preserved:
+  forall m stk f,
+  Mem.free m stk 0 (Mach.fn_stacksize f) = Mem.free m stk 0 (fn_stacksize (transf_function f)).
+Proof.
+  intros. auto.
+Qed.
+
+Local Hint Resolve symbols_preserved senv_preserved init_mem_preserved prog_main_preserved functions_translated
+                   parent_sp_preserved.
+
+Definition dist_end_block_code (c: Mach.code) := (size (fst (to_bblock c))-1)%nat.
+
+
+Definition dist_end_block (s: Mach.state): nat :=
+  match s with
+  | Mach.State _ _ _ c _ _ => dist_end_block_code c
+  | _ => 0
+  end.
+
+Local Hint Resolve exec_nil_body exec_cons_body.
+Local Hint Resolve exec_MBgetstack exec_MBsetstack exec_MBgetparam exec_MBop exec_MBload exec_MBstore.
+
+Ltac ExploitDistEndBlockCode :=
+  match goal with
+  | [ H : dist_end_block_code (Mlabel ?l :: ?c) <> 0%nat |- _ ] =>
+      exploit (to_bblock_size_single_label c (Mlabel l)); eauto
+  | [ H : dist_end_block_code (?i0 :: ?c) <> 0%nat |- _ ] =>
+      exploit (to_bblock_size_single_basic c i0); eauto
+  | _ => idtac
+  end.
+
+Ltac totologize H :=
+  match type of H with
+  | ( ?id = _ ) =>
+    let Hassert := fresh "Htoto" in (
+    assert (id = id) as Hassert; auto; rewrite H in Hassert at 2; simpl in Hassert; rewrite H in Hassert)
+  end.
+
+Lemma dist_end_block_code_simu_mid_block i c:
+  dist_end_block_code (i::c) <> 0 ->
+  (dist_end_block_code (i::c) = Datatypes.S (dist_end_block_code c)).
+Proof.
+  intros H.
+  unfold dist_end_block_code.
+  destruct (get_code_nature (i::c)) eqn:GCNIC.
+  - apply get_code_nature_empty in GCNIC. discriminate.
+  - rewrite to_bblock_size_single_label; auto.
+    destruct c as [|i' c].
+    + contradict H. destruct i; simpl; auto.
+    + assert (size (fst (to_bblock (i'::c))) <> 0). apply to_bblock_nonil. omega. 
+  - destruct (get_code_nature c) eqn:GCNC.
+    + apply get_code_nature_empty in GCNC. subst. contradict H. destruct i; simpl; auto.
+    + contradict H. destruct c as [|i' c]; try discriminate.
+      destruct i'; try discriminate.
+      destruct i; try discriminate. all: simpl; auto.
+    + destruct (to_basic_inst i) eqn:TBI; [| destruct i; discriminate].
+      erewrite to_bblock_basic; eauto; [| rewrite GCNC; discriminate ].
+      simpl. destruct c as [|i' c]; try discriminate.
+      assert (size (fst (to_bblock (i'::c))) <> 0). apply to_bblock_nonil.
+      cutrewrite (Datatypes.S (size (fst (to_bblock (i'::c))) - 1) = size (fst (to_bblock (i'::c)))).
+      unfold size. cutrewrite (length (header (fst (to_bblock (i' :: c)))) = 0). simpl. omega.
+      rewrite to_bblock_noLabel. simpl; auto.
+      rewrite GCNC. discriminate.
+      omega.
+    + destruct (to_basic_inst i) eqn:TBI; [| destruct i; discriminate].
+      erewrite to_bblock_basic; eauto; [| rewrite GCNC; discriminate ].
+      simpl. destruct c as [|i' c]; try discriminate.
+      assert (size (fst (to_bblock (i'::c))) <> 0). apply to_bblock_nonil.
+      cutrewrite (Datatypes.S (size (fst (to_bblock (i'::c))) - 1) = size (fst (to_bblock (i'::c)))).
+      unfold size. cutrewrite (length (header (fst (to_bblock (i' :: c)))) = 0). simpl. omega.
+      rewrite to_bblock_noLabel. simpl; auto.
+      rewrite GCNC. discriminate.
+      omega.
+  - contradict H. destruct i; try discriminate.
+    all: unfold dist_end_block_code; erewrite to_bblock_CFI; eauto; simpl; eauto.
+Qed.
+
+Local Hint Resolve dist_end_block_code_simu_mid_block.
+
+Lemma step_simu_basic_step (i: Mach.instruction) (bi: basic_inst) (c: Mach.code) s f sp rs m (t:trace) (s':Mach.state):
+  to_basic_inst i = Some bi ->
+  Mach.step (inv_trans_rao rao) ge (Mach.State s f sp (i::c) rs m) t s' ->
+  exists rs' m', s'=Mach.State s f sp c rs' m' /\ t=E0 /\ basic_step tge (trans_stack s) f sp rs m bi rs' m'.
+Proof.
+  destruct i; simpl in * |-;
+   (discriminate
+    || (intro H; inversion_clear H; intro X; inversion_clear X; eapply ex_intro; eapply ex_intro; intuition eauto)).
+  - eapply exec_MBgetparam; eauto. exploit (functions_translated); eauto. intro.
+    destruct H3 as (tf & A & B). subst. eapply A.
+    all: simpl; rewrite <- parent_sp_preserved; auto.
+  - eapply exec_MBop; eauto. rewrite <- H. destruct o; simpl; auto. destruct (rs ## l); simpl; auto.
+    unfold Genv.symbol_address; rewrite symbols_preserved; auto.
+  - eapply exec_MBload; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto;
+    unfold Genv.symbol_address; rewrite symbols_preserved; auto.
+  - eapply exec_MBstore; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto;
+    unfold Genv.symbol_address; rewrite symbols_preserved; auto.
+Qed.
+
+
+Lemma star_step_simu_body_step s f sp c:
+ forall (p:bblock_body) c' rs m t s',
+  to_bblock_body c = (p, c') ->
+  starN (Mach.step (inv_trans_rao rao)) ge (length p) (Mach.State s f sp c rs m) t s' ->
+  exists rs' m', s'=Mach.State s f sp c' rs' m' /\ t=E0 /\ body_step tge (trans_stack s) f sp p rs m rs' m'.
+Proof.
+  induction c as [ | i0 c0 Hc0]; simpl; intros p c' rs m t s' H.
+  * (* nil *)
+    inversion_clear H; simpl; intros X; inversion_clear X.
+    eapply ex_intro; eapply ex_intro; intuition eauto.
+  * (* cons *)
+    remember (to_basic_inst i0) as o eqn:Ho.
+    destruct o as [bi |].
+    + (* to_basic_inst i0 = Some bi *)
+      remember (to_bblock_body c0) as r eqn:Hr.
+      destruct r as [p1 c1]; inversion H; simpl; subst; clear H.
+      intros X; inversion_clear X.
+      exploit step_simu_basic_step; eauto.
+      intros [rs' [m' [H2 [H3 H4]]]]; subst.
+      exploit Hc0; eauto.
+      intros [rs'' [m'' [H5 [H6 H7]]]]; subst.
+      refine (ex_intro _ rs'' (ex_intro _ m'' _)); intuition eauto.
+   + (* to_basic_inst i0 = None *)
+     inversion_clear H; simpl.
+     intros X; inversion_clear X. intuition eauto.
+Qed.
+
+Local Hint Resolve exec_MBcall exec_MBtailcall exec_MBbuiltin exec_MBgoto exec_MBcond_true exec_MBcond_false exec_MBjumptable exec_MBreturn exec_Some_exit exec_None_exit.
+Local Hint Resolve eval_builtin_args_preserved external_call_symbols_preserved find_funct_ptr_same.
+
+Lemma match_states_concat_trans_code st f sp c rs m h: 
+  match_states (Mach.State st f sp c rs m) (State (trans_stack st) f sp (concat h (trans_code c)) rs m).
+Proof.
+  constructor 1; simpl.
+  + intros (t0 & s1' & H0) t s'. 
+    rewrite! trans_code_equation.
+    destruct c as [| i c]. { inversion H0. }
+    remember (to_bblock (i :: c)) as bic. destruct bic as [b c0].
+    simpl.
+    constructor 1; intros H; inversion H; subst; simpl in * |- *;
+    eapply exec_bblock; eauto.
+    - inversion H11; subst; eauto.
+      inversion H2; subst; eauto.
+    - inversion H11; subst; simpl; eauto.
+      inversion H2; subst; simpl; eauto.
+  + intros H r; constructor 1; intro X; inversion X.
+Qed.
+
+Lemma step_simu_cfi_step:
+  forall c e c' stk f sp rs m t s' b lb',
+  to_bblock_exit c = (Some e, c') ->
+  trans_code c' = lb' ->
+  Mach.step (inv_trans_rao rao) ge (Mach.State stk f sp c rs m) t s' ->
+  exists s2, cfi_step rao tge e (State (trans_stack stk) f sp (b::lb') rs m) t s2 /\ match_states s' s2.
+Proof.
+  intros c e c' stk f sp rs m t s' b lb'.
+  intros Hexit Htc Hstep.
+  destruct c as [|ei c]; try (contradict Hexit; discriminate).
+  destruct ei; (contradict Hexit; discriminate) || (
+    inversion Hexit; subst; inversion Hstep; subst; simpl
+  ).
+  * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto.
+    apply exec_MBcall with (f := (transf_function f0)); auto.
+    rewrite find_function_ptr_same in H9; auto.
+  * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto.
+    apply exec_MBtailcall with (f := (transf_function f0)); auto.
+    rewrite find_function_ptr_same in H9; auto.
+    rewrite parent_sp_preserved in H11; subst; auto.
+    rewrite parent_ra_preserved in H12; subst; auto.
+  * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto.
+    eapply exec_MBbuiltin; eauto.
+  * exploit find_label_transcode_preserved; eauto. intros (h & X1 & X2).
+    eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto.
+  * exploit find_label_transcode_preserved; eauto. intros (h & X1 & X2).
+    eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto.
+  * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto.
+    eapply exec_MBcond_false; eauto.
+  * exploit find_label_transcode_preserved; eauto. intros (h & X1 & X2).
+    eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto.
+  * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto.
+    eapply exec_MBreturn; eauto.
+    rewrite parent_sp_preserved in H8; subst; auto.
+    rewrite parent_ra_preserved in H9; subst; auto.
+Qed.
+
+
+
+Lemma step_simu_exit_step c e c' stk f sp rs m t s' b:
+  to_bblock_exit c = (e, c') ->
+  starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length_opt e) (Mach.State stk f sp c rs m) t s' ->
+  exists s2, exit_step rao tge e (State (trans_stack stk) f sp (b::trans_code c') rs m) t s2 /\ match_states s' s2.
+Proof.
+  intros H1 H2; destruct e as [ e |]; inversion_clear H2. 
+  + (* Some *) inversion H0; clear H0; subst. autorewrite with trace_rewrite.
+    exploit step_simu_cfi_step; eauto.
+    intros (s2' & H2 & H3); eapply ex_intro; intuition eauto.
+  + (* None *) 
+     destruct c as [ |i c]; simpl in H1; inversion H1.
+     - eapply ex_intro; intuition eauto; try eapply match_states_trans_state.
+     - remember to_cfi as o. destruct o; try discriminate.
+       inversion_clear H1.
+       eapply ex_intro; intuition eauto; try eapply match_states_trans_state.
+Qed.
+
+Lemma step_simu_header st f sp rs m s c: forall h c' t, 
+ (h, c') = to_bblock_header c ->
+ starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length h) (Mach.State st f sp c rs m) t s -> s = Mach.State st f sp c' rs m /\ t = E0.
+Proof.
+   induction c as [ | i c]; simpl; intros h c' t H.
+   - inversion_clear H. simpl; intros H; inversion H; auto.
+   - destruct i; try (injection H; clear H; intros H H2; subst; simpl; intros H; inversion H; subst; auto).
+     remember (to_bblock_header c) as bhc. destruct bhc as [h0 c0].
+     injection H; clear H; intros H H2; subst; simpl; intros H; inversion H; subst.
+     inversion H1; clear H1; subst; auto. autorewrite with trace_rewrite.
+     exploit IHc; eauto.
+Qed. 
+
+Lemma simu_end_block:
+  forall s1 t s1',
+  starN (Mach.step (inv_trans_rao rao)) ge (Datatypes.S (dist_end_block s1)) s1 t s1' ->
+  exists s2', step rao tge (trans_state s1) t s2' /\ match_states s1' s2'.
+Proof.
+  destruct s1; simpl.
+  + (* State *)
+    (* c cannot be nil *)
+    destruct c as [|i c]; simpl; try ( (* nil => absurd *)
+      unfold dist_end_block_code; simpl;
+      intros t s1' H; inversion_clear H;
+      inversion_clear H0; fail
+    ).
+
+    intros t s1' H.
+    remember (_::_) as c0. remember (trans_code c0) as tc0.
+
+    (* tc0 cannot be nil *)
+    destruct tc0; try
+    ( exploit (trans_code_nonil c0); subst; auto; try discriminate; intro H0; contradict H0 ).
+
+    assert (X: Datatypes.S (dist_end_block_code c0) = (size (fst (to_bblock c0)))).
+    {
+      unfold dist_end_block_code. remember (size _) as siz.
+      assert (siz <> 0%nat). rewrite Heqsiz; subst; apply to_bblock_nonil with (c0 := c) (i := i); auto.
+      omega.
+    }
+
+    (* decomposition of starN in 3 parts: header + body + exit *)
+    rewrite X in H; unfold size in H.
+    destruct (starN_split (Mach.semantics (inv_trans_rao rao) prog) _ _ _ _ H _ _ refl_equal) as [t3 [t4 [s1 [H0 [H3 H4]]]]].
+    subst t; clear X H.
+    destruct (starN_split (Mach.semantics (inv_trans_rao rao) prog) _ _ _ _ H0 _ _ refl_equal) as [t1 [t2 [s0 [H [H1 H2]]]]].
+    subst t3; clear H0.
+
+    unfold to_bblock in * |- *.
+    (* naming parts of block "b" *)
+    remember (to_bblock_header c0) as hd. destruct hd as [hb c1].
+    remember (to_bblock_body c1) as bb. destruct bb as [bb c2].
+    remember (to_bblock_exit c2) as exb. destruct exb as [exb c3].
+    simpl in * |- *.
+
+    exploit trans_code_step; eauto. intro EQ. destruct EQ as (EQH & EQB & EQE & EQTB0).
+    subst hb bb exb.
+
+    (* header opt step *)
+    exploit step_simu_header; eauto.
+    intros [X1 X2]; subst s0 t1.
+    autorewrite with trace_rewrite.
+    (* body steps *)
+    exploit (star_step_simu_body_step); eauto.
+    clear H1; intros [rs' [m' [H0 [H1 H2]]]].
+    subst s1 t2. autorewrite with trace_rewrite.
+    (* exit step *)
+    subst tc0.
+    exploit step_simu_exit_step; eauto. clear H3.
+    intros (s2' & H3 & H4).
+    eapply ex_intro; intuition eauto.
+    eapply exec_bblock; eauto.
+  + (* Callstate *)
+    intros t s1' H; inversion_clear H.
+    eapply ex_intro; constructor 1; eauto.
+    inversion H1; subst; clear H1.
+    inversion_clear H0; simpl.
+    - (* function_internal*)
+      cutrewrite (trans_code (Mach.fn_code f0) = fn_code (transf_function f0)); eauto.
+      eapply exec_function_internal; eauto.
+      rewrite <- parent_sp_preserved; eauto.
+      rewrite <- parent_ra_preserved; eauto.
+    - (* function_external *)
+      autorewrite with trace_rewrite.
+      eapply exec_function_external; eauto.
+      apply find_funct_ptr_same_external; auto.
+      rewrite <- parent_sp_preserved; eauto.
+  +  (* Returnstate *)
+    intros t s1' H; inversion_clear H.
+    eapply ex_intro; constructor 1; eauto.
+    inversion H1; subst; clear H1.
+    inversion_clear H0; simpl.
+    eapply exec_return.
+Qed.
+
+Theorem transf_program_correct: 
+    forward_simulation (Mach.semantics (inv_trans_rao rao) prog) (Machblock.semantics rao tprog).
+Proof.
+  apply forward_simulation_block_trans with (dist_end_block := dist_end_block) (trans_state := trans_state).
+(* simu_mid_block *)
+  - intros s1 t s1' H1.
+    destruct H1; simpl; omega || (intuition auto).
+(* public_preserved *)
+  - apply senv_preserved.
+(* match_initial_states *)
+  - intros. simpl.
+    eapply ex_intro; constructor 1.
+    eapply match_states_trans_state.
+    destruct H. split.
+    apply init_mem_preserved; auto.
+    rewrite prog_main_preserved. rewrite <- H0. apply symbols_preserved.
+(* match_final_states *)
+  - intros. simpl. destruct H. split with (r := r); auto.
+(* final_states_end_block *)
+  - intros. simpl in H0. inversion H0.
+    inversion H; simpl; auto.
+    (* the remaining instructions cannot lead to a Returnstate *)
+    all: subst; discriminate.
+(* simu_end_block *)
+  - apply simu_end_block.
+Qed.
+
+End PRESERVATION.
diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp
index b3e07bf5..26735c99 100644
--- a/mppa_k1c/SelectLong.vp
+++ b/mppa_k1c/SelectLong.vp
@@ -292,14 +292,10 @@ Definition notl (e: expr) :=
 
 (** ** Integer division and modulus *)
 
-Definition divlu_base (e1: expr) (e2: expr) :=
-  if Archi.splitlong then SplitLong.divlu_base e1 e2 else Eop Odivlu (e1:::e2:::Enil).
-Definition modlu_base (e1: expr) (e2: expr) :=
-  if Archi.splitlong then SplitLong.modlu_base e1 e2 else Eop Omodlu (e1:::e2:::Enil).
-Definition divls_base (e1: expr) (e2: expr) :=
-  if Archi.splitlong then SplitLong.divls_base e1 e2 else Eop Odivl (e1:::e2:::Enil).
-Definition modls_base (e1: expr) (e2: expr) :=
-  if Archi.splitlong then SplitLong.modls_base e1 e2 else Eop Omodl (e1:::e2:::Enil).
+Definition divlu_base (e1: expr) (e2: expr) := SplitLong.divlu_base e1 e2.
+Definition modlu_base (e1: expr) (e2: expr) := SplitLong.modlu_base e1 e2.
+Definition divls_base (e1: expr) (e2: expr) := SplitLong.divls_base e1 e2.
+Definition modls_base (e1: expr) (e2: expr) := SplitLong.modls_base e1 e2.
 
 Definition shrxlimm (e: expr) (n: int) :=
   if Archi.splitlong then SplitLong.shrxlimm e n else
diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml
index f3babcd6..143b7622 100644
--- a/mppa_k1c/TargetPrinter.ml
+++ b/mppa_k1c/TargetPrinter.ml
@@ -40,7 +40,7 @@ module Target : TARGET =
 
     let print_label oc lbl = label oc (transl_label lbl)
 
-    let int_reg_name = function
+    let int_reg_name = let open Asmblock in function
       | GPR0  -> "$r0"  | GPR1  -> "$r1"  | GPR2  -> "$r2"  | GPR3  -> "$r3"
       | GPR4  -> "$r4"  | GPR5  -> "$r5"  | GPR6  -> "$r6"  | GPR7  -> "$r7"
       | GPR8  -> "$r8"  | GPR9  -> "$r9"  | GPR10 -> "$r10" | GPR11 -> "$r11"
@@ -62,13 +62,13 @@ module Target : TARGET =
 
     let ireg = ireg
 
-    let preg oc = function
+    let preg oc = let open Asmblock in function
       | IR r -> ireg oc r
       | FR r -> ireg oc r
       | RA   -> output_string oc "$ra"
-      | _    -> assert false
+      | _ -> assert false
 
-    let preg_annot = function
+    let preg_annot = let open Asmblock in function
       | IR r -> int_reg_name r
       | FR r -> int_reg_name r
       | RA   -> "$ra"
@@ -149,11 +149,11 @@ module Target : TARGET =
   *)
 (* Offset part of a load or store *)
 
-    let offset oc = function
+    let offset oc = let open Asmblock in function
     | Ofsimm n -> ptrofs oc n
     | Ofslow(id, ofs) -> fprintf oc "%%lo(%a)" symbol_offset (id, ofs)
 
-    let icond_name = function
+    let icond_name = let open Asmblock in function
       | ITne | ITneu -> "ne"
       | ITeq | ITequ -> "eq"
       | ITlt   -> "lt"
@@ -171,7 +171,7 @@ module Target : TARGET =
 
     let icond oc c = fprintf oc "%s" (icond_name c)
   
-    let bcond_name = function
+    let bcond_name = let open Asmblock in function
       | BTwnez -> "wnez"
       | BTweqz -> "weqz"
       | BTwltz -> "wltz"
@@ -188,7 +188,7 @@ module Target : TARGET =
     let bcond oc c = fprintf oc "%s" (bcond_name c)
 
 (* Printing of instructions *)
-    let print_ex_instruction oc = function
+    let print_instruction oc = function
       (* Pseudo-instructions expanded in Asmexpand *)
       | Pallocframe(sz, ofs) ->
          assert false
@@ -221,127 +221,13 @@ module Target : TARGET =
           | _ ->
               assert false
          end
+      | Pnop -> fprintf oc "	nop\n;;\n"
+
+      | Pclzll (rd, rs) -> fprintf oc "	clzd %a = %a\n;;\n" ireg rd ireg rs
+      | Pstsud (rd, rs1, rs2) -> fprintf oc "	stsud %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
 
-      (* Pseudo-instructions not generated by Asmgen *)
-         (* BCU instructions *)
-      | Pawait ->
-         fprintf oc "	await	\n;;\n"
-      | Pbarrier ->
-         fprintf oc "	barrier	\n;;\n"
-      | Pdoze ->
-         fprintf oc "	doze	\n;;\n"
-      | Pwfxl(rs1, rs2) ->
-         fprintf oc "	wfxl	%a, %a\n;;\n" ireg rs1 ireg rs2
-      | Pwfxm(rs1, rs2) ->
-         fprintf oc "	wfxm	%a, %a\n;;\n" ireg rs1 ireg rs2
-      | Pinvaldtlb ->
-         fprintf oc "	invaldtlb	\n;;\n"
-      | Pinvalitlb ->
-         fprintf oc "	invalitlb	\n;;\n"
-      | Pprobetlb ->
-         fprintf oc "	probetlb	\n;;\n"
-      | Preadtlb ->
-         fprintf oc "	readtlb	\n;;\n"
-      | Psleep ->
-         fprintf oc "	sleep	\n;;\n"
-      | Pstop ->
-         fprintf oc "	stop	\n;;\n"
-      | Psyncgroup(rs) ->
-         fprintf oc "	syncgroup	%a\n;;\n" ireg rs
-      | Ptlbwrite ->
-         fprintf oc "	tlbwrite	\n;;\n"
-
-         (* LSU instructions *)
-      | Pafda(rd, rs1, rs2) ->
-         fprintf oc "	afda	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
-      | Paldc(rd, rs1) ->
-         fprintf oc "	aldc	%a = %a\n;;\n" ireg rd ireg rs1
-      | Pdinval ->
-         fprintf oc "	dinval	\n;;\n"
-      | Pdinvall (rs) ->
-         fprintf oc "	dinvall	%a\n;;\n" ireg rs
-      | Pdtouchl (rs) ->
-         fprintf oc "	dtouchl	%a\n;;\n" ireg rs
-      | Pdzerol (rs) ->
-         fprintf oc "	dzerol	%a\n;;\n" ireg rs
-      | Pfence ->
-         fprintf oc "	fence	\n;;\n"
-      | Piinval ->
-         fprintf oc "	iinval	\n;;\n"
-      | Piinvals (rs) ->
-         fprintf oc "	iinvals	%a\n;;\n" ireg rs
-      | Pitouchl (rs) ->
-         fprintf oc "	itouchl	%a\n;;\n" ireg rs
-      | Plbsu(rd, rs1) ->
-         fprintf oc "	lbsu	%a = %a\n;;\n" ireg rd ireg rs1
-      | Plbzu(rd, rs1) ->
-         fprintf oc "	lbzu	%a = %a\n;;\n" ireg rd ireg rs1
-      | Pldu(rd, rs1) ->
-         fprintf oc "	ldu	%a = %a\n;;\n" ireg rd ireg rs1
-      | Plhsu(rd, rs1) ->
-         fprintf oc "	lhsu	%a = %a\n;;\n" ireg rd ireg rs1
-      | Plhzu(rd, rs1) ->
-         fprintf oc "	lhzu	%a = %a\n;;\n" ireg rd ireg rs1
-      | Plwzu(rd, rs1) ->
-         fprintf oc "	lwzu	%a = %a\n;;\n" ireg rd ireg rs1
-
-         (* ALU instructions *)
-      | Paddhp(rd, rs1, rs2) ->
-         fprintf oc "	addhp	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
-      | Padds(rd, rs1, rs2) ->
-         fprintf oc "	adds	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
-      | Pbwlu(rd, rs1, rs2, rs3, rs4, rs5) ->
-         fprintf oc "	bwlu	%a = %a, %a, %a, %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 ireg rs3 ireg rs4 ireg rs5
-      | Pbwluhp(rd, rs1, rs2, rs3) ->
-         fprintf oc "	bwluhp	%a = %a, %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 ireg rs3
-      | Pbwluwp(rd, rs1, rs2, rs3) ->
-         fprintf oc "	bwluwp	%a = %a, %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 ireg rs3
-      | Pcbs(rd, rs) ->
-         fprintf oc "	cbs	%a = %a\n;;\n" ireg rd ireg rs
-      | Pcbsdl(rd, rs) ->
-         fprintf oc "	cbsdl	%a = %a\n;;\n" ireg rd ireg rs
-      | Pclz(rd, rs) ->
-         fprintf oc "	clz	%a = %a\n;;\n" ireg rd ireg rs
-      | Pclzw(rd, rs) ->
-         fprintf oc "	clzw	%a = %a\n;;\n" ireg rd ireg rs
-      | Pclzd(rd, rs) ->
-         fprintf oc "	clzd	%a = %a\n;;\n" ireg rd ireg rs
-      | Pclzdl(rd, rs) ->
-         fprintf oc "	clzdl	%a = %a\n;;\n" ireg rd ireg rs
-      | Pcmove(rd, rs1, rs2, rs3) ->
-         fprintf oc "	cmove	%a = %a, %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 ireg rs3
-      | Pctz(rd, rs) ->
-         fprintf oc "	ctz	%a = %a\n;;\n" ireg rd ireg rs
-      | Pctzw(rd, rs) ->
-         fprintf oc "	ctzw	%a = %a\n;;\n" ireg rd ireg rs
-      | Pctzd(rd, rs) ->
-         fprintf oc "	ctzd	%a = %a\n;;\n" ireg rd ireg rs
-      | Pctzdl(rd, rs) ->
-         fprintf oc "	ctzdl	%a = %a\n;;\n" ireg rd ireg rs
-      | Pextfz(rd, rs1, rs2, rs3) ->
-         fprintf oc "	extfz	%a = %a, %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 ireg rs3
-      | Plandhp(rd, rs1, rs2, rs3) ->
-         fprintf oc "	landhp	%a = %a, %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 ireg rs3
-      | Psat(rd, rs1, rs2) ->
-         fprintf oc "	sat	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
-      | Psatd(rd, rs1, rs2) ->
-         fprintf oc "	satd	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
-      | Psbfhp(rd, rs1, rs2) ->
-         fprintf oc "	sbfhp	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
-      | Psbmm8(rd, rs1, rs2) ->
-         fprintf oc "	sbmm8	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
-      | Psbmmt8(rd, rs1, rs2) ->
-         fprintf oc "	sbmmt8	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
-      | Psllhps(rd, rs1, rs2) ->
-         fprintf oc "	sllhps	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
-      | Psrahps(rd, rs1, rs2) ->
-         fprintf oc "	srahps	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
-      | Pstsu(rd, rs1, rs2) ->
-         fprintf oc "	stsu	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
-      | Pstsud(rd, rs1, rs2) ->
-         fprintf oc "	stsud	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
-
-      let print_cf_instruction oc = function
+
+      (* Control flow instructions *)
       | Pget (rd, rs) ->
          fprintf oc "	get	%a = %a\n;;\n" ireg rd preg rs
       | Pset (rd, rs) ->
@@ -357,7 +243,7 @@ module Target : TARGET =
       | Pcb (bt, r, lbl) | Pcbu (bt, r, lbl) ->
          fprintf oc "	cb.%a	%a?%a\n;;\n" bcond bt ireg r print_label lbl
 
-      let print_ld_instruction oc = function
+      (* Load/Store instructions *)
       | Plb(rd, ra, ofs) ->
          fprintf oc "	lbs	%a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra
       | Plbu(rd, ra, ofs) ->
@@ -370,8 +256,7 @@ module Target : TARGET =
          fprintf oc "	lws	%a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra
       | Pld(rd, ra, ofs) | Pfld(rd, ra, ofs) | Pld_a(rd, ra, ofs) -> assert Archi.ptr64;
          fprintf oc "	ld	%a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra
-
-      let print_st_instruction oc = function
+    
       | Psb(rd, ra, ofs) ->
          fprintf oc "	sb	%a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd
       | Psh(rd, ra, ofs) ->
@@ -381,124 +266,108 @@ module Target : TARGET =
       | Psd(rd, ra, ofs) | Psd_a(rd, ra, ofs) | Pfsd(rd, ra, ofs) -> assert Archi.ptr64;
          fprintf oc "	sd	%a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd
 
-      let print_ar_r_instruction oc rd = (* function
-      | Pcvtw2l ->*) assert false
+      (* Arith R instructions *)
+      | Pcvtw2l(rd) -> assert false
 
-      let print_ar_rr_instruction oc rd rs = function
-      | Pmv | Pmvw2l ->
+      (* Arith RR instructions *)
+      | Pmv(rd, rs) | Pmvw2l(rd, rs) ->
          fprintf oc "	addd	%a = %a, 0\n;;\n"     ireg rd ireg rs
-      | Pcvtl2w -> assert false
-      | Pnegl -> assert Archi.ptr64;
+      | Pcvtl2w(rd, rs) -> assert false
+      | Pnegl(rd, rs) -> assert Archi.ptr64;
          fprintf oc "	negd	%a = %a\n;;\n" ireg rd ireg rs
-      | Pnegw ->
+      | Pnegw(rd, rs) ->
          fprintf oc "	negw	%a = %a\n;;\n" ireg rd ireg rs
-      | Pfnegd ->
+      | Pfnegd(rd, rs) ->
          fprintf oc "	fnegd	%a = %a\n;;\n" ireg rs ireg rd
 
-      let print_ar_ri32_instruction oc rd imm = (* function  
-         | Pmake (rd, imm) -> *)
+      (* Arith RI32 instructions *)
+      | Pmake (rd, imm) ->
          fprintf oc "	make	%a, %a\n;;\n" ireg rd coqint imm
 
-      let print_ar_ri64_instruction oc rd imm = (* function
-         | Pmakel (rd, imm) -> *)
+      (* Arith RI64 instructions *)
+      | Pmakel (rd, imm) ->
          fprintf oc "	make	%a, %a\n;;\n" ireg rd coqint64 imm
 
-      let print_ar_rrr_instruction oc rd rs1 rs2 = function
-      | Pcompw (it) ->
+      (* Arith RRR instructions *)
+      | Pcompw (it, rd, rs1, rs2) ->
          fprintf oc "	compw.%a	%a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2
-      | Pcompl (it) ->
+      | Pcompl (it, rd, rs1, rs2) ->
          fprintf oc "	compd.%a	%a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2
 
-      | Paddw ->
+      | Paddw (rd, rs1, rs2) ->
          fprintf oc "	addw	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
-      | Psubw ->
+      | Psubw (rd, rs1, rs2) ->
          fprintf oc "	sbfw	%a = %a, %a\n;;\n" ireg rd ireg rs2 ireg rs1
-      | Pmulw ->
+      | Pmulw (rd, rs1, rs2) ->
          fprintf oc "	mulw	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
-      | Pandw ->
+      | Pandw (rd, rs1, rs2) ->
          fprintf oc "	andw	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
-      | Porw -> 
+      | Porw (rd, rs1, rs2) -> 
          fprintf oc "	orw	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
-      | Pxorw -> 
+      | Pxorw (rd, rs1, rs2) -> 
          fprintf oc "	xorw	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
-      | Psraw ->
+      | Psraw (rd, rs1, rs2) ->
          fprintf oc "	sraw	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
-      | Psrlw ->
+      | Psrlw (rd, rs1, rs2) ->
          fprintf oc "	srlw	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
-      | Psllw ->
+      | Psllw (rd, rs1, rs2) ->
          fprintf oc "	sllw	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
 
-      | Paddl -> assert Archi.ptr64;
+      | Paddl (rd, rs1, rs2) -> assert Archi.ptr64;
          fprintf oc "	addd	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
-      | Psubl ->
+      | Psubl (rd, rs1, rs2) ->
          fprintf oc "	sbfd	%a = %a, %a\n;;\n" ireg rd ireg rs2 ireg rs1
-      | Pandl -> assert Archi.ptr64;
+      | Pandl (rd, rs1, rs2) -> assert Archi.ptr64;
          fprintf oc "	andd	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
-      | Porl -> assert Archi.ptr64;
+      | Porl (rd, rs1, rs2) -> assert Archi.ptr64;
          fprintf oc "	ord	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
-      | Pxorl -> assert Archi.ptr64;
+      | Pxorl (rd, rs1, rs2) -> assert Archi.ptr64;
          fprintf oc "	xord	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
-      | Pmull ->
+      | Pmull (rd, rs1, rs2) ->
          fprintf oc "	muld	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
-      | Pslll  ->
+      | Pslll  (rd, rs1, rs2) ->
          fprintf oc "	slld	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
-      | Psrll  ->
+      | Psrll  (rd, rs1, rs2) ->
          fprintf oc "	srld	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
-      | Psral   ->
+      | Psral   (rd, rs1, rs2) ->
          fprintf oc "	srad	%a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2
 
-    let print_ar_rri32_instruction oc rd rs imm = function
-      | Pcompiw (it) ->
+      (* Arith RRI32 instructions *)
+      | Pcompiw (it, rd, rs, imm) ->
          fprintf oc "	compw.%a	%a = %a, %a\n;;\n" icond it ireg rd ireg rs coqint64 imm
-      | Paddiw ->
+      | Paddiw (rd, rs, imm) ->
          fprintf oc "	addw	%a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm
-      | Pandiw ->
+      | Pandiw (rd, rs, imm) ->
          fprintf oc "	andw	%a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm
-      | Poriw -> 
+      | Poriw (rd, rs, imm) -> 
          fprintf oc "	orw	%a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm
-      | Pxoriw -> 
+      | Pxoriw (rd, rs, imm) -> 
          fprintf oc "	xorw	%a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm
-      | Psraiw ->
+      | Psraiw (rd, rs, imm) ->
          fprintf oc "	sraw	%a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm
-      | Psrliw ->
+      | Psrliw (rd, rs, imm) ->
          fprintf oc "	srlw	%a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm
-      | Pslliw ->
+      | Pslliw (rd, rs, imm) ->
          fprintf oc "	sllw	%a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm
-      | Psllil ->
+      | Psllil (rd, rs, imm) ->
          fprintf oc "	slld	%a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm
-      | Psrlil ->
+      | Psrlil (rd, rs, imm) ->
          fprintf oc "	srld	%a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm
-      | Psrail ->
+      | Psrail (rd, rs, imm) ->
          fprintf oc "	srad	%a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm
 
-    let print_ar_rri64_instruction oc rd rs imm = function
-      | Pcompil (it) ->
+    (* Arith RRI64 instructions *)
+      | Pcompil (it, rd, rs, imm) ->
          fprintf oc "	compd.%a	%a = %a, %a\n;;\n" icond it ireg rd ireg rs coqint64 imm
-      | Paddil -> assert Archi.ptr64;
+      | Paddil (rd, rs, imm) -> assert Archi.ptr64;
          fprintf oc "	addd	%a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm
-      | Pandil -> assert Archi.ptr64;
+      | Pandil (rd, rs, imm) -> assert Archi.ptr64;
          fprintf oc "	andd	%a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm
-      | Poril -> assert Archi.ptr64;
+      | Poril (rd, rs, imm) -> assert Archi.ptr64;
          fprintf oc "	ord	%a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm
-      | Pxoril -> assert Archi.ptr64;
+      | Pxoril (rd, rs, imm) -> assert Archi.ptr64;
          fprintf oc "	xord	%a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm
 
-    let print_ar_instruction oc = function
-      | PArithR(d) -> print_ar_r_instruction oc d
-      | PArithRR(ins, d, s) -> print_ar_rr_instruction oc d s ins
-      | PArithRI32(d, i) -> print_ar_ri32_instruction oc d i
-      | PArithRI64(d, i) -> print_ar_ri64_instruction oc d i
-      | PArithRRR(ins, d, s1, s2) -> print_ar_rrr_instruction oc d s1 s2 ins
-      | PArithRRI32(ins, d, s, i) -> print_ar_rri32_instruction oc d s i ins
-      | PArithRRI64(ins, d, s, i) -> print_ar_rri64_instruction oc d s i ins
-
-    let print_instruction oc = function
-      | PExpand(i) -> print_ex_instruction oc i
-      | PControlFlow(i) -> print_cf_instruction oc i
-      | PLoad(i) -> print_ld_instruction oc i
-      | PStore(i) -> print_st_instruction oc i
-      | PArith(i) -> print_ar_instruction oc i
-
     let get_section_names name =
       let (text, lit) =
         match C2C.atom_sections name with
diff --git a/mppa_k1c/extractionMachdep.v b/mppa_k1c/extractionMachdep.v
index c9a1040a..e70f51de 100644
--- a/mppa_k1c/extractionMachdep.v
+++ b/mppa_k1c/extractionMachdep.v
@@ -23,5 +23,7 @@ Extract Constant Archi.ptr64 => " Configuration.model = ""64"" ".
 Extract Constant Archi.pic_code => "fun () -> false".  (* for the time being *)
 
 (* Asm *)
+(*
 Extract Constant Asm.low_half => "fun _ _ _ -> assert false".
 Extract Constant Asm.high_half => "fun _ _ _ -> assert false".
+*)
diff --git a/test/mppa/.gitignore b/test/mppa/.gitignore
index f03fc12c..e8ebeff8 100644
--- a/test/mppa/.gitignore
+++ b/test/mppa/.gitignore
@@ -1 +1,20 @@
 check
+asm_coverage
+instr/Makefile
+mmult/Makefile
+prng/Makefile
+sort/Makefile
+prng/.zero
+sort/.zero
+sort/insertion-ccomp-k1c
+sort/insertion-gcc-k1c
+sort/insertion-gcc-x86
+sort/main-ccomp-k1c
+sort/main-gcc-k1c
+sort/main-gcc-x86
+sort/merge-ccomp-k1c
+sort/merge-gcc-k1c
+sort/merge-gcc-x86
+sort/selection-ccomp-k1c
+sort/selection-gcc-k1c
+sort/selection-gcc-x86
diff --git a/test/mppa/Makefile b/test/mppa/Makefile
deleted file mode 100644
index 22f22945..00000000
--- a/test/mppa/Makefile
+++ /dev/null
@@ -1,90 +0,0 @@
-DIR=general
-BINDIR=bin
-ASMDIR=asm
-TESTNAMES=$(notdir $(subst .c,,$(wildcard $(DIR)/*.c)))
-
-CCOMP=../../ccomp
-ELF=$(addprefix $(DIR)/$(BINDIR)/,$(addsuffix .bin,$(TESTNAMES)))
-TOK=$(addprefix $(DIR)/$(BINDIR)/,$(addsuffix .tok,$(TESTNAMES)))
-ASM=$(addprefix $(DIR)/$(ASMDIR)/,$(addsuffix .s,$(TESTNAMES)))
-DEBUG:=$(if $(DEBUG),"-dall",)
-
-.PHONY: all
-all: $(ELF)
-
-nobin: $(ASM)
-
-##
-# Assembling CompCert's assembly file
-##
-$(DIR)/$(BINDIR)/%.bin: $(DIR)/$(ASMDIR)/%.s
-	@mkdir -p $(@D)
-	ccomp $< -o $@
-
-##
-# Compiling the C file with CompCert
-##
-.SECONDARY:
-$(DIR)/$(ASMDIR)/%.s: $(DIR)/%.c $(CCOMP)
-	@mkdir -p $(@D)
-	ccomp $(DEBUG) -O0 -v -S $< -o $@
-
-##
-# A token (.tok) is created if the .bin (created by CompCert) yields the same
-# result as the .bin.exp (created by executing the binary compiled with gcc)
-##
-$(DIR)/$(BINDIR)/%.tok: $(DIR)/$(BINDIR)/%.bin $(DIR)/output/%.bin.exp
-	@mkdir -p $(@D)
-	@bash check.sh $< $@
-
-##
-# Generate .bin.exp : compile with gcc, execute, store the result in .bin.exp
-##
-$(DIR)/output/%.bin.exp: $(DIR)/%.c
-	@bash generate.sh $< $@
-
-.PHONY: FORCE
-FORCE:
-
-.PHONY: check
-check: $(TOK) sort mmult
-
-##
-# A utility displaying which of the pseudo-instructions are covered in the tests
-##
-.PHONY: coverage
-coverage: $(ASM)
-	bash coverage.sh $(DIR)/$(ASMDIR)
-
-##
-# Different versions of a sorting algorithm
-##
-.PHONY: sort
-sort: FORCE
-	(cd sort && make compc-check)
-
-##
-# Different versions of a matrix multiply
-##
-.PHONY: mmult
-mmult: FORCE
-	(cd mmult && make compc-check)
-
-.PHONY: clean
-clean:
-	rm -f $(DIR)/*.alloctrace
-	rm -f $(DIR)/*.cm
-	rm -f $(DIR)/*.compcert.c
-	rm -f $(DIR)/*.i
-	rm -f $(DIR)/*.light.c
-	rm -f $(DIR)/*.ltl
-	rm -f $(DIR)/*.mach
-	rm -f $(DIR)/*.parsed.c
-	rm -f $(DIR)/*.rtl.?
-	rm -f $(DIR)/$(ASMDIR)/*.s
-	rm -f $(DIR)/$(BINDIR)/*.bin
-	rm -f $(DIR)/$(BINDIR)/*.tok
-	rm -f $(DIR)/output/*.out
-	rm -f $(DIR)/output/*.exp
-	rm -rf $(DIR)/profile/
-	rm -f $(ELF)
diff --git a/test/mppa/builtins/clzll.c b/test/mppa/builtins/clzll.c
new file mode 100644
index 00000000..13905cba
--- /dev/null
+++ b/test/mppa/builtins/clzll.c
@@ -0,0 +1,7 @@
+#include "framework.h"
+
+BEGIN_TEST(long long)
+{
+    c = __builtin_clzll(a);
+}
+END_TEST()
diff --git a/test/mppa/general/stsud.c b/test/mppa/builtins/stsud.c
index fb07b94f..fb07b94f 100644
--- a/test/mppa/general/stsud.c
+++ b/test/mppa/builtins/stsud.c
diff --git a/test/mppa/check.sh b/test/mppa/check.sh
index dd9691be..8db50f1b 100644..100755
--- a/test/mppa/check.sh
+++ b/test/mppa/check.sh
@@ -1,32 +1,6 @@
-# $1: binary file to check
-# $2: output check token
+#!/bin/bash
+# Tests the execution of the binaries produced by CompCert
 
-elffile="$1"
-token="$2"
+source do_test.sh
 
-if [ ! -f $elffile ]; then
-	>&2 echo "ERROR: $elffile not found"
-	shift; continue
-fi
-
-dir="$(dirname $elffile)"
-elf="$(basename $elffile)"
-
-exp="$dir/../output/$elf.exp"
-out="$dir/../output/$elf.out"
-if [ ! -f $exp ]; then
-	>&2 echo "ERROR: $exp not found"
-	exit
-fi
-
-k1-cluster -- $elffile > $out
-echo $? >> $out
-
-if ! diff $exp $out; then
-	>&2 echo "ERROR: $exp and $out differ"
-	exit
-fi
-
-echo "PASSED: $elf"
-touch $token
-#shift
+do_test check
diff --git a/test/mppa/do_test.sh b/test/mppa/do_test.sh
new file mode 100644
index 00000000..ee7cbcf7
--- /dev/null
+++ b/test/mppa/do_test.sh
@@ -0,0 +1,33 @@
+do_test () {
+cat << EOF
+
+##
+# PRNG tests
+##
+EOF
+(cd prng && make $1 -j8)
+
+cat << EOF
+
+##
+# Matrix Multiplication tests
+##
+EOF
+(cd mmult && make $1 -j8)
+
+cat << EOF
+
+##
+# List sort tests
+##
+EOF
+(cd sort && make $1 -j8)
+
+cat << EOF
+
+##
+# Instruction unit tests
+##
+EOF
+(cd instr && make $1 -j8)
+}
diff --git a/test/mppa/generate.sh b/test/mppa/generate.sh
deleted file mode 100644
index ea633724..00000000
--- a/test/mppa/generate.sh
+++ /dev/null
@@ -1,21 +0,0 @@
-# $1: c file to examine
-# $2: write file
-
-cfile="$1"
-writefile="$2"
-
-dirwritefile=$(dirname $writefile)
-asmdir=$dirwritefile/../asm/gcc
-
-if [ ! -f $cfile ]; then
-	>&2 echo "ERROR: $cfile not found"
-	shift; continue
-fi
-
-mkdir -p $dirwritefile
-mkdir -p $asmdir
-
-tmpbin=/tmp/k1-$(basename $1)-bin 
-k1-gcc -O0 $1 -S -o $asmdir/$(basename $1).s
-k1-gcc -O0 $1 -o $tmpbin
-(k1-cluster -- $tmpbin; echo $? > $2)
diff --git a/test/mppa/general/.gitignore b/test/mppa/instr/.gitignore
index ea1472ec..ea1472ec 100644
--- a/test/mppa/general/.gitignore
+++ b/test/mppa/instr/.gitignore
diff --git a/test/mppa/instr/Makefile b/test/mppa/instr/Makefile
new file mode 100644
index 00000000..89ff9a73
--- /dev/null
+++ b/test/mppa/instr/Makefile
@@ -0,0 +1,111 @@
+K1CC ?= k1-mbr-gcc
+CC ?= gcc
+CCOMP ?= ccomp
+CFLAGS ?= -O2
+SIMU ?= k1-cluster
+TIMEOUT ?= 10s
+
+DIR=./
+SRCDIR=$(DIR)
+OUTDIR=$(DIR)/out
+BINDIR=$(DIR)/bin
+ASMDIR=$(DIR)/asm
+
+##
+# Intended flow : .c -> .gcc.s -> .gcc.bin -> .gcc.out
+#                    -> .ccomp.s -> .ccomp.bin -> .ccomp.out
+##
+
+K1CCPATH=$(shell which $(K1CC))
+CCPATH=$(shell which $(CC))
+CCOMPPATH=$(shell which $(CCOMP))
+SIMUPATH=$(shell which $(SIMU))
+
+TESTNAMES=$(notdir $(subst .c,,$(wildcard $(DIR)/*.c)))
+X86_GCC_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .x86-gcc.out,$(TESTNAMES)))
+GCC_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.out,$(TESTNAMES)))
+CCOMP_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.out,$(TESTNAMES)))
+
+OUT=$(X86_GCC_OUT) $(GCC_OUT) $(CCOMP_OUT)
+BIN=$(addprefix $(BINDIR)/,$(addsuffix .x86-gcc.bin,$(TESTNAMES)))\
+	$(addprefix $(BINDIR)/,$(addsuffix .gcc.bin,$(TESTNAMES)))\
+	$(addprefix $(BINDIR)/,$(addsuffix .ccomp.bin,$(TESTNAMES)))
+
+##
+# Targets
+##
+
+all: $(BIN)
+
+.PHONY:
+test: $(X86_GCC_OUT) $(GCC_OUT)
+	@echo "Comparing x86 gcc output to k1 gcc.."
+	@for test in $(TESTNAMES); do\
+		x86out=$(OUTDIR)/$$test.x86-gcc.out;\
+		gccout=$(OUTDIR)/$$test.gcc.out;\
+		if ! diff $$x86out $$gccout; then\
+			>&2 echo "ERROR: $$x86out and $$gccout differ";\
+		else\
+			echo "GOOD: $$x86out and $$gccout concur";\
+		fi;\
+	done
+
+.PHONY:
+check: $(GCC_OUT) $(CCOMP_OUT)
+	@echo "Comparing k1 gcc output to ccomp.."
+	@for test in $(TESTNAMES); do\
+		gccout=$(OUTDIR)/$$test.gcc.out;\
+		ccompout=$(OUTDIR)/$$test.ccomp.out;\
+		if ! diff $$ccompout $$gccout; then\
+			>&2 echo "ERROR: $$ccompout and $$gccout differ";\
+		else\
+			echo "GOOD: $$ccompout and $$gccout concur";\
+		fi;\
+	done
+
+##
+# Rules
+##
+
+.SECONDARY:
+# Generating output
+
+$(OUTDIR)/%.x86-gcc.out: $(BINDIR)/%.x86-gcc.bin
+	@mkdir -p $(@D)
+	ret=0; timeout $(TIMEOUT) ./$< > $@ || { ret=$$?; }; echo $$ret >> $@
+
+$(OUTDIR)/%.gcc.out: $(BINDIR)/%.gcc.bin $(SIMUPATH)
+	@mkdir -p $(@D)
+	ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@
+
+$(OUTDIR)/%.ccomp.out: $(BINDIR)/%.ccomp.bin $(SIMUPATH)
+	@mkdir -p $(@D)
+	ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@
+
+# Assembly to binary
+
+$(BINDIR)/%.x86-gcc.bin: $(ASMDIR)/%.x86-gcc.s $(CCPATH)
+	@mkdir -p $(@D)
+	$(CC) $(CFLAGS) $< -o $@
+
+$(BINDIR)/%.gcc.bin: $(ASMDIR)/%.gcc.s $(K1CCPATH)
+	@mkdir -p $(@D)
+	$(K1CC) $(CFLAGS) $< -o $@
+
+$(BINDIR)/%.ccomp.bin: $(ASMDIR)/%.ccomp.s $(CCOMPPATH)
+	@mkdir -p $(@D)
+	$(CCOMP) $(CFLAGS) $< -o $@
+
+# Source to assembly
+
+$(ASMDIR)/%.x86-gcc.s: $(SRCDIR)/%.c $(CCPATH)
+	@mkdir -p $(@D)
+	$(CC) $(CFLAGS) -S $< -o $@
+
+$(ASMDIR)/%.gcc.s: $(SRCDIR)/%.c $(K1CCPATH)
+	@mkdir -p $(@D)
+	$(K1CC) $(CFLAGS) -S $< -o $@
+
+$(ASMDIR)/%.ccomp.s: $(SRCDIR)/%.c $(CCOMPPATH)
+	@mkdir -p $(@D)
+	$(CCOMP) $(CFLAGS) -S $< -o $@
diff --git a/test/mppa/general/addw.c b/test/mppa/instr/addw.c
index be8afc67..be8afc67 100644
--- a/test/mppa/general/addw.c
+++ b/test/mppa/instr/addw.c
diff --git a/test/mppa/general/andd.c b/test/mppa/instr/andd.c
index 4f503764..4f503764 100644
--- a/test/mppa/general/andd.c
+++ b/test/mppa/instr/andd.c
diff --git a/test/mppa/general/andw.c b/test/mppa/instr/andw.c
index 99de0049..99de0049 100644
--- a/test/mppa/general/andw.c
+++ b/test/mppa/instr/andw.c
diff --git a/test/mppa/general/branch.c b/test/mppa/instr/branch.c
index 72e7e20e..72e7e20e 100644
--- a/test/mppa/general/branch.c
+++ b/test/mppa/instr/branch.c
diff --git a/test/mppa/general/branchz.c b/test/mppa/instr/branchz.c
index fb86d357..fb86d357 100644
--- a/test/mppa/general/branchz.c
+++ b/test/mppa/instr/branchz.c
diff --git a/test/mppa/general/branchzu.c b/test/mppa/instr/branchzu.c
index 97adb605..97adb605 100644
--- a/test/mppa/general/branchzu.c
+++ b/test/mppa/instr/branchzu.c
diff --git a/test/mppa/general/call.c b/test/mppa/instr/call.c
index 727cef63..727cef63 100644
--- a/test/mppa/general/call.c
+++ b/test/mppa/instr/call.c
diff --git a/test/mppa/general/cb.deqz.c b/test/mppa/instr/cb.deqz.c
index c56733f0..c56733f0 100644
--- a/test/mppa/general/cb.deqz.c
+++ b/test/mppa/instr/cb.deqz.c
diff --git a/test/mppa/general/cb.dgez.c b/test/mppa/instr/cb.dgez.c
index abb6ec57..abb6ec57 100644
--- a/test/mppa/general/cb.dgez.c
+++ b/test/mppa/instr/cb.dgez.c
diff --git a/test/mppa/general/cb.dgtz.c b/test/mppa/instr/cb.dgtz.c
index d4271845..d4271845 100644
--- a/test/mppa/general/cb.dgtz.c
+++ b/test/mppa/instr/cb.dgtz.c
diff --git a/test/mppa/general/cb.dlez.c b/test/mppa/instr/cb.dlez.c
index 18e67f06..18e67f06 100644
--- a/test/mppa/general/cb.dlez.c
+++ b/test/mppa/instr/cb.dlez.c
diff --git a/test/mppa/general/cb.dltz.c b/test/mppa/instr/cb.dltz.c
index 366aea49..366aea49 100644
--- a/test/mppa/general/cb.dltz.c
+++ b/test/mppa/instr/cb.dltz.c
diff --git a/test/mppa/general/cb.dnez.c b/test/mppa/instr/cb.dnez.c
index 81c2cd29..81c2cd29 100644
--- a/test/mppa/general/cb.dnez.c
+++ b/test/mppa/instr/cb.dnez.c
diff --git a/test/mppa/general/cb.wgez.c b/test/mppa/instr/cb.wgez.c
index 477f4bc6..477f4bc6 100644
--- a/test/mppa/general/cb.wgez.c
+++ b/test/mppa/instr/cb.wgez.c
diff --git a/test/mppa/general/cb.wgtz.c b/test/mppa/instr/cb.wgtz.c
index c9ab9a06..c9ab9a06 100644
--- a/test/mppa/general/cb.wgtz.c
+++ b/test/mppa/instr/cb.wgtz.c
diff --git a/test/mppa/general/cb.wlez.c b/test/mppa/instr/cb.wlez.c
index c3069fda..c3069fda 100644
--- a/test/mppa/general/cb.wlez.c
+++ b/test/mppa/instr/cb.wlez.c
diff --git a/test/mppa/general/cb.wltz.c b/test/mppa/instr/cb.wltz.c
index 6cf5fcf0..6cf5fcf0 100644
--- a/test/mppa/general/cb.wltz.c
+++ b/test/mppa/instr/cb.wltz.c
diff --git a/test/mppa/general/compd.eq.c b/test/mppa/instr/compd.eq.c
index d19a4d20..d19a4d20 100644
--- a/test/mppa/general/compd.eq.c
+++ b/test/mppa/instr/compd.eq.c
diff --git a/test/mppa/general/compd.geu.c b/test/mppa/instr/compd.geu.c
index edc31183..edc31183 100644
--- a/test/mppa/general/compd.geu.c
+++ b/test/mppa/instr/compd.geu.c
diff --git a/test/mppa/general/compd.gt.c b/test/mppa/instr/compd.gt.c
index 24147779..24147779 100644
--- a/test/mppa/general/compd.gt.c
+++ b/test/mppa/instr/compd.gt.c
diff --git a/test/mppa/general/compd.gtu.c b/test/mppa/instr/compd.gtu.c
index 5ce82569..5ce82569 100644
--- a/test/mppa/general/compd.gtu.c
+++ b/test/mppa/instr/compd.gtu.c
diff --git a/test/mppa/general/compd.le.c b/test/mppa/instr/compd.le.c
index a84aad97..a84aad97 100644
--- a/test/mppa/general/compd.le.c
+++ b/test/mppa/instr/compd.le.c
diff --git a/test/mppa/general/compd.leu.c b/test/mppa/instr/compd.leu.c
index e386bc27..e386bc27 100644
--- a/test/mppa/general/compd.leu.c
+++ b/test/mppa/instr/compd.leu.c
diff --git a/test/mppa/general/compd.lt.c b/test/mppa/instr/compd.lt.c
index df07a708..df07a708 100644
--- a/test/mppa/general/compd.lt.c
+++ b/test/mppa/instr/compd.lt.c
diff --git a/test/mppa/general/compd.ltu.c b/test/mppa/instr/compd.ltu.c
index dfaa8921..dfaa8921 100644
--- a/test/mppa/general/compd.ltu.c
+++ b/test/mppa/instr/compd.ltu.c
diff --git a/test/mppa/general/compd.ne.c b/test/mppa/instr/compd.ne.c
index 19ce0a69..19ce0a69 100644
--- a/test/mppa/general/compd.ne.c
+++ b/test/mppa/instr/compd.ne.c
diff --git a/test/mppa/general/compw.eq.c b/test/mppa/instr/compw.eq.c
index dc7a3ab1..dc7a3ab1 100644
--- a/test/mppa/general/compw.eq.c
+++ b/test/mppa/instr/compw.eq.c
diff --git a/test/mppa/general/compw.geu.c b/test/mppa/instr/compw.geu.c
index d72ca56c..d72ca56c 100644
--- a/test/mppa/general/compw.geu.c
+++ b/test/mppa/instr/compw.geu.c
diff --git a/test/mppa/general/compw.gt.c b/test/mppa/instr/compw.gt.c
index 9ad02610..9ad02610 100644
--- a/test/mppa/general/compw.gt.c
+++ b/test/mppa/instr/compw.gt.c
diff --git a/test/mppa/general/compw.gtu.c b/test/mppa/instr/compw.gtu.c
index 77f04989..77f04989 100644
--- a/test/mppa/general/compw.gtu.c
+++ b/test/mppa/instr/compw.gtu.c
diff --git a/test/mppa/general/compw.le.c b/test/mppa/instr/compw.le.c
index b7a7a432..b7a7a432 100644
--- a/test/mppa/general/compw.le.c
+++ b/test/mppa/instr/compw.le.c
diff --git a/test/mppa/general/compw.leu.c b/test/mppa/instr/compw.leu.c
index 4892f06c..4892f06c 100644
--- a/test/mppa/general/compw.leu.c
+++ b/test/mppa/instr/compw.leu.c
diff --git a/test/mppa/general/compw.lt.c b/test/mppa/instr/compw.lt.c
index 2cc151bf..2cc151bf 100644
--- a/test/mppa/general/compw.lt.c
+++ b/test/mppa/instr/compw.lt.c
diff --git a/test/mppa/general/compw.ltu.c b/test/mppa/instr/compw.ltu.c
index b524127f..b524127f 100644
--- a/test/mppa/general/compw.ltu.c
+++ b/test/mppa/instr/compw.ltu.c
diff --git a/test/mppa/general/compw.ne.c b/test/mppa/instr/compw.ne.c
index 433b0b86..433b0b86 100644
--- a/test/mppa/general/compw.ne.c
+++ b/test/mppa/instr/compw.ne.c
diff --git a/test/mppa/general/div2.c b/test/mppa/instr/div2.c
index 01a4b575..01a4b575 100644
--- a/test/mppa/general/div2.c
+++ b/test/mppa/instr/div2.c
diff --git a/test/mppa/general/for.c b/test/mppa/instr/for.c
index d6870afb..d6870afb 100644
--- a/test/mppa/general/for.c
+++ b/test/mppa/instr/for.c
diff --git a/test/mppa/general/forvar.c b/test/mppa/instr/forvar.c
index 57548274..57548274 100644
--- a/test/mppa/general/forvar.c
+++ b/test/mppa/instr/forvar.c
diff --git a/test/mppa/general/forvarl.c b/test/mppa/instr/forvarl.c
index 30717a51..30717a51 100644
--- a/test/mppa/general/forvarl.c
+++ b/test/mppa/instr/forvarl.c
diff --git a/test/mppa/general/framework.h b/test/mppa/instr/framework.h
index b7dc4933..52ba97bc 100644
--- a/test/mppa/general/framework.h
+++ b/test/mppa/instr/framework.h
@@ -1,7 +1,7 @@
 #ifndef __FRAMEWORK_H__
 #define __FRAMEWORK_H__
 
-#include "../lib/prng.c"
+#include "../prng/prng.c"
 
 #define BEGIN_TEST_N(type, N)\
     int main(void){\
diff --git a/test/mppa/general/lbs.c b/test/mppa/instr/lbs.c
index f104d62b..f104d62b 100644
--- a/test/mppa/general/lbs.c
+++ b/test/mppa/instr/lbs.c
diff --git a/test/mppa/general/lbz.c b/test/mppa/instr/lbz.c
index 2deeaebe..2deeaebe 100644
--- a/test/mppa/general/lbz.c
+++ b/test/mppa/instr/lbz.c
diff --git a/test/mppa/general/muld.c b/test/mppa/instr/muld.c
index 9a40f389..9a40f389 100644
--- a/test/mppa/general/muld.c
+++ b/test/mppa/instr/muld.c
diff --git a/test/mppa/general/mulw.c b/test/mppa/instr/mulw.c
index bf517ce8..bf517ce8 100644
--- a/test/mppa/general/mulw.c
+++ b/test/mppa/instr/mulw.c
diff --git a/test/mppa/general/negd.c b/test/mppa/instr/negd.c
index a8e8ff45..a8e8ff45 100644
--- a/test/mppa/general/negd.c
+++ b/test/mppa/instr/negd.c
diff --git a/test/mppa/general/ord.c b/test/mppa/instr/ord.c
index eaedcb28..eaedcb28 100644
--- a/test/mppa/general/ord.c
+++ b/test/mppa/instr/ord.c
diff --git a/test/mppa/general/sbfd.c b/test/mppa/instr/sbfd.c
index 912f1fdb..912f1fdb 100644
--- a/test/mppa/general/sbfd.c
+++ b/test/mppa/instr/sbfd.c
diff --git a/test/mppa/general/sbfw.c b/test/mppa/instr/sbfw.c
index feffd497..feffd497 100644
--- a/test/mppa/general/sbfw.c
+++ b/test/mppa/instr/sbfw.c
diff --git a/test/mppa/general/simple.c b/test/mppa/instr/simple.c
index 89bba27e..89bba27e 100644
--- a/test/mppa/general/simple.c
+++ b/test/mppa/instr/simple.c
diff --git a/test/mppa/general/sllw.c b/test/mppa/instr/sllw.c
index df55c9e8..df55c9e8 100644
--- a/test/mppa/general/sllw.c
+++ b/test/mppa/instr/sllw.c
diff --git a/test/mppa/general/srad.c b/test/mppa/instr/srad.c
index b4047bc7..b4047bc7 100644
--- a/test/mppa/general/srad.c
+++ b/test/mppa/instr/srad.c
diff --git a/test/mppa/general/srld.c b/test/mppa/instr/srld.c
index 71e82b2a..71e82b2a 100644
--- a/test/mppa/general/srld.c
+++ b/test/mppa/instr/srld.c
diff --git a/test/mppa/general/udivd.c b/test/mppa/instr/udivd.c
index 52e0d412..52e0d412 100644
--- a/test/mppa/general/udivd.c
+++ b/test/mppa/instr/udivd.c
diff --git a/test/mppa/general/umodd.c b/test/mppa/instr/umodd.c
index e7dd506f..e7dd506f 100644
--- a/test/mppa/general/umodd.c
+++ b/test/mppa/instr/umodd.c
diff --git a/test/mppa/general/xord.c b/test/mppa/instr/xord.c
index b9d86f06..b9d86f06 100644
--- a/test/mppa/general/xord.c
+++ b/test/mppa/instr/xord.c
diff --git a/test/mppa/lib/.gitignore b/test/mppa/lib/.gitignore
deleted file mode 100644
index 1879eaee..00000000
--- a/test/mppa/lib/.gitignore
+++ /dev/null
@@ -1,2 +0,0 @@
-prng-test-k1c
-prng-test-x86
diff --git a/test/mppa/lib/Makefile b/test/mppa/lib/Makefile
deleted file mode 100644
index 7aeab9f3..00000000
--- a/test/mppa/lib/Makefile
+++ /dev/null
@@ -1,30 +0,0 @@
-prng-test-x86: prng.c
-	gcc -D__UNIT_TEST_PRNG__ -O2 -std=c99 $< -o $@
-
-prng-test-k1c: prng.c
-	k1-gcc -D__UNIT_TEST_PRNG__ -O2 -std=c99 $< -o $@
-
-.PHONY:
-test: test-x86 test-k1c
-
-.PHONY:
-test-x86: prng-test-x86
-	@if ! ./$<; then\
-		>&2 echo "ERROR: $< failed";\
-		exit;\
-	else\
-		echo "x86: Test Succeeded";\
-	fi
-
-.PHONY:
-test-k1c: prng-test-k1c
-	@if ! k1-cluster -- ./$<; then\
-		>&2 echo "ERROR: $< failed";\
-		exit;\
-	else\
-		echo "k1c: Test Succeeded";\
-	fi
-
-.PHONY:
-clean:
-	rm -f prng-test-x86 prng-test-k1c
diff --git a/test/mppa/mmult/.gitignore b/test/mppa/mmult/.gitignore
index 5883d367..c9cd4c65 100644
--- a/test/mppa/mmult/.gitignore
+++ b/test/mppa/mmult/.gitignore
@@ -1,3 +1,4 @@
-mmult-test-k1c
-mmult-test-x86
-test-ccomp
+mmult-test-ccomp-k1c
+mmult-test-gcc-k1c
+mmult-test-gcc-x86
+.zero
diff --git a/test/mppa/mmult/Makefile b/test/mppa/mmult/Makefile
index 23b31d49..cf82e359 100644
--- a/test/mppa/mmult/Makefile
+++ b/test/mppa/mmult/Makefile
@@ -1,78 +1,67 @@
-PRNG=../lib/prng.c
-CCOMP=../../../ccomp
-
-ALL= mmult-test-x86 mmult-test-k1c\
+K1CC ?= k1-mbr-gcc
+CC ?= gcc
+CCOMP ?= ccomp
+CFLAGS ?= -O2
+SIMU ?= k1-cluster
+TIMEOUT ?= 10s
+
+K1CCPATH=$(shell which $(K1CC))
+CCPATH=$(shell which $(CC))
+CCOMPPATH=$(shell which $(CCOMP))
+SIMUPATH=$(shell which $(SIMU))
+
+PRNG=../prng/prng.c
+
+ALL= mmult-test-gcc-x86 mmult-test-gcc-k1c mmult-test-ccomp-k1c
+CCOMP_OUT= mmult-test-ccomp-k1c.out
+GCC_OUT= mmult-test-gcc-k1c.out
+X86_GCC_OUT= mmult-test-gcc-x86.out
+STUB_OUT=.zero
 
 all: $(ALL)
 
-%-test-x86: %.c $(PRNG)
-	gcc -D__UNIT_TEST_$$(echo $(basename $<) | tr a-z A-Z)__ -O2 -std=c99 $^ -o $@
-
-%-test-k1c: %.c $(PRNG)
-	k1-gcc -D__UNIT_TEST_$$(echo $(basename $<) | tr a-z A-Z)__ -O2 -std=c99 $^ -o $@
+mmult-test-gcc-x86: mmult.c $(PRNG) $(CCPATH)
+	$(CC) $(CFLAGS) $(filter-out $(CCPATH),$^) -o $@
 
-test-x86: mmult.c $(PRNG)
-	gcc -O2 -std=c99 $^ -o $@
+mmult-test-gcc-k1c: mmult.c $(PRNG) $(K1CCPATH)
+	$(K1CC) $(CFLAGS) $(filter-out $(K1CCPATH),$^) -o $@
 
-test-k1c: mmult.c $(PRNG)
-	k1-gcc -O2 -std=c99 $^ -o $@
+mmult-test-ccomp-k1c: mmult.c $(PRNG) $(CCOMPPATH)
+	$(CCOMP) $(CFLAGS) $(filter-out $(CCOMPPATH),$^) -o $@
 
-%.s: %.c $(CCOMP)
-	ccomp -O2 -S $< -o $@
+.SECONDARY:
+%k1c.out: %k1c $(SIMUPATH)
+	ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@
 
-test-ccomp: mmult.s $(subst .c,.s,$(PRNG))
-	k1-gcc $^ -o $@
+%x86.out: %x86
+	ret=0; timeout $(TIMEOUT) ./$< > $@ || { ret=$$?; }; echo $$ret >> $@
 
-.PHONY:
-unittest: unittest-x86 unittest-k1c
+.zero:
+	@echo "0" > $@
 
 .PHONY:
-check: check-x86 check-k1c
+test: test-x86 test-k1c
 
 .PHONY:
-compc-check: test-ccomp
-	@if ! k1-cluster -- ./$<; then\
-		>&2 echo "ERROR k1c: mmult $< failed";\
+test-x86: $(X86_GCC_OUT) $(STUB_OUT)
+	@if ! diff $< $(STUB_OUT); then\
+		>&2 echo "ERROR x86: $< failed";\
 	else\
-		echo "k1c: Test mmult $< succeeded";\
+		echo "GOOD x86: $< succeeded";\
 	fi
 
 .PHONY:
-check-x86: test-x86
-	@if ! ./$<; then\
-		>&2 echo "ERROR x86: $< failed";\
+test-k1c: $(GCC_OUT) $(STUB_OUT)
+	@if ! diff $< $(STUB_OUT); then\
+		>&2 echo "ERROR k1c: $< failed";\
 	else\
-		echo "x86: Test $< succeeded";\
+		echo "GOOD k1c: $< succeeded";\
 	fi
 
 .PHONY:
-check-k1c: test-k1c
-	@if ! k1-cluster -- ./$<; then\
+check: $(CCOMP_OUT) $(STUB_OUT)
+	@if ! diff $< $(STUB_OUT); then\
 		>&2 echo "ERROR k1c: $< failed";\
 	else\
-		echo "k1c: Test $< succeeded";\
+		echo "GOOD k1c: $< succeeded";\
 	fi
-
-.PHONY:
-unittest-x86: mmult-test-x86
-	@for test in $^; do\
-		if ! ./$$test; then\
-			>&2 echo "ERROR x86: $$test failed";\
-		else\
-			echo "x86: Test $$test Succeeded";\
-		fi;\
-	done
-
-.PHONY:
-unittest-k1c: mmult-test-k1c
-	@for test in $^; do\
-		if ! k1-cluster -- ./$$test; then\
-			>&2 echo "ERROR k1c: $$test failed";\
-		else\
-			echo "k1c: Test $$test Succeeded";\
-		fi;\
-	done
-
-.PHONY:
-clean:
-	rm -f $(ALL)
diff --git a/test/mppa/mmult/README.md b/test/mppa/mmult/README.md
new file mode 100644
index 00000000..ef2bff7e
--- /dev/null
+++ b/test/mppa/mmult/README.md
@@ -0,0 +1,17 @@
+MMULT
+=====
+
+Examples of matrix multiplication using different methods.
+
+We compute matrix multiplication using column-based matrix multiplication, then row-based, and finally block based.
+
+The test verifies that the result is the same on the three methods. If it is the same, 0 will be returned.
+
+The following commands can be run inside the folder:
+
+- `make`: produces the unitary test binaries
+  - `mmult-test-gcc-x86` : binary from gcc on x86
+  - `mmult-test-k1c-x86` : binary from gcc on k1c
+  - `mmult-test-ccomp-x86` : binary from ccomp on k1c
+- `make test`: tests the return value of the binaries produced by gcc.
+- `make check`: tests the return value of the binary produced by CompCert.
diff --git a/test/mppa/mmult/mmult.c b/test/mppa/mmult/mmult.c
index b674ca80..aeb91d48 100644
--- a/test/mppa/mmult/mmult.c
+++ b/test/mppa/mmult/mmult.c
@@ -1,5 +1,5 @@
-#include "../lib/types.h"
-#include "../lib/prng.h"
+#include "../prng/types.h"
+#include "../prng/prng.h"
 
 #define __UNIT_TEST_MMULT__
 
@@ -10,24 +10,28 @@
 #endif
 
 void mmult_row(uint64_t C[][SIZE], uint64_t A[][SIZE], uint64_t B[][SIZE]){
-    for (int i = 0 ; i < SIZE ; i++)
-        for (int j = 0 ; j < SIZE ; j++)
+    int i, j, k;
+
+    for (i = 0 ; i < SIZE ; i++)
+        for (j = 0 ; j < SIZE ; j++)
             C[i][j] = 0;
 
-    for (int i = 0 ; i < SIZE ; i++)
-        for (int j = 0 ; j < SIZE ; j++)
-            for (int k = 0 ; k < SIZE ; k++)
+    for (i = 0 ; i < SIZE ; i++)
+        for (j = 0 ; j < SIZE ; j++)
+            for (k = 0 ; k < SIZE ; k++)
                 C[i][j] += A[i][k] * B[k][j];
 }
 
 void mmult_col(uint64_t C[][SIZE], uint64_t A[][SIZE], uint64_t B[][SIZE]){
-    for (int i = 0 ; i < SIZE ; i++)
-        for (int j = 0 ; j < SIZE ; j++)
+    int i, j, k;
+
+    for (i = 0 ; i < SIZE ; i++)
+        for (j = 0 ; j < SIZE ; j++)
             C[i][j] = 0;
 
-    for (int k = 0 ; k < SIZE ; k++)
-        for (int i = 0 ; i < SIZE ; i++)
-            for (int j = 0 ; j < SIZE ; j++)
+    for (k = 0 ; k < SIZE ; k++)
+        for (i = 0 ; i < SIZE ; i++)
+            for (j = 0 ; j < SIZE ; j++)
                 C[i][j] += A[i][k] * B[k][j];
 }
 
@@ -41,10 +45,11 @@ typedef struct mblock {
 
 void divac_mul(mblock *C, const mblock *A, const mblock *B){
     const int size = C->imax - C->imin;
+    int i, j, k;
 
-    for (int i = 0 ; i < size ; i++)
-        for (int j = 0 ; j < size ; j++)
-            for (int k = 0 ; k < size ; k++)
+    for (i = 0 ; i < size ; i++)
+        for (j = 0 ; j < size ; j++)
+            for (k = 0 ; k < size ; k++)
                 MAT_IJ(C, i, j) += MAT_IJ(A, i, k) * MAT_IJ(B, k, j);
 }
 
@@ -119,9 +124,10 @@ static uint64_t A[SIZE][SIZE], B[SIZE][SIZE];
 
 int main(void){
     srand(42);
+    int i, j;
 
-    for (int i = 0 ; i < SIZE ; i++)
-        for (int j = 0 ; j < SIZE ; j++){
+    for (i = 0 ; i < SIZE ; i++)
+        for (j = 0 ; j < SIZE ; j++){
             A[i][j] = randlong();
             B[i][j] = randlong();
         }
@@ -130,8 +136,8 @@ int main(void){
     mmult_col(C2, A, B);
     mmult_divac(C3, A, B);
 
-    for (int i = 0 ; i < SIZE ; i++)
-        for (int j = 0 ; j < SIZE ; j++)
+    for (i = 0 ; i < SIZE ; i++)
+        for (j = 0 ; j < SIZE ; j++)
             if (!(C1[i][j] == C2[i][j] && C1[i][j] == C3[i][j]))
                 return -1;
 
diff --git a/test/mppa/prng/.gitignore b/test/mppa/prng/.gitignore
new file mode 100644
index 00000000..0792a78b
--- /dev/null
+++ b/test/mppa/prng/.gitignore
@@ -0,0 +1,3 @@
+prng-test-ccomp-k1c
+prng-test-gcc-x86
+prng-test-gcc-k1c
diff --git a/test/mppa/prng/Makefile b/test/mppa/prng/Makefile
new file mode 100644
index 00000000..5580cd8e
--- /dev/null
+++ b/test/mppa/prng/Makefile
@@ -0,0 +1,69 @@
+K1CC ?= k1-mbr-gcc
+CC ?= gcc
+CCOMP ?= ccomp
+CFLAGS ?= -O2
+SIMU ?= k1-cluster
+TIMEOUT ?= 10s
+
+K1CCPATH=$(shell which $(K1CC))
+CCPATH=$(shell which $(CC))
+CCOMPPATH=$(shell which $(CCOMP))
+SIMUPATH=$(shell which $(SIMU))
+
+ALL= prng-test-gcc-x86 prng-test-gcc-k1c prng-test-ccomp-k1c
+CCOMP_OUT= prng-test-ccomp-k1c.out
+GCC_OUT= prng-test-gcc-k1c.out
+X86_GCC_OUT= prng-test-gcc-x86.out
+STUB_OUT=.zero
+
+all: $(ALL)
+
+prng-test-gcc-x86: prng.c $(CCPATH)
+	$(CC) -D__UNIT_TEST_PRNG__ $(CFLAGS) $< -o $@
+
+prng-test-gcc-k1c: prng.c $(K1CCPATH)
+	$(K1CC) -D__UNIT_TEST_PRNG__ $(CFLAGS) $< -o $@
+
+prng-test-ccomp-k1c: prng.c $(CCOMPPATH)
+	$(CCOMP) -D__UNIT_TEST_PRNG__ $(CFLAGS) $< -o $@
+
+.SECONDARY:
+%k1c.out: %k1c $(SIMUPATH)
+	ret=0; timeout $(TIMEOUT) $(SIMU) -- $<  > $@ || { ret=$$?; }; echo $$ret >> $@
+
+%x86.out: %x86
+	ret=0; timeout $(TIMEOUT) ./$< > $@ || { ret=$$?; }; echo $$ret >> $@
+
+.zero:
+	@echo "0" > $@
+
+.PHONY:
+test: test-x86 test-k1c
+
+.PHONY:
+test-x86: $(X86_GCC_OUT) $(STUB_OUT)
+	@if ! diff $< $(STUB_OUT); then\
+		>&2 echo "ERROR x86: $< failed";\
+	else\
+		echo "GOOD x86: $< succeeded";\
+	fi
+
+.PHONY:
+test-k1c: $(GCC_OUT) $(STUB_OUT)
+	@if ! diff $< $(STUB_OUT); then\
+		>&2 echo "ERROR k1c: $< failed";\
+	else\
+		echo "GOOD k1c: $< succeeded";\
+	fi
+
+.PHONY:
+check: $(CCOMP_OUT) $(STUB_OUT)
+	@if ! diff $< $(STUB_OUT); then\
+		>&2 echo "ERROR k1c: $< failed";\
+	else\
+		echo "GOOD k1c: $< succeeded";\
+	fi
+
+.PHONY:
+clean:
+	rm -f prng-test-gcc-x86 prng-test-gcc-k1c prng-test-ccomp-k1c
diff --git a/test/mppa/prng/README.md b/test/mppa/prng/README.md
new file mode 100644
index 00000000..b4c2279b
--- /dev/null
+++ b/test/mppa/prng/README.md
@@ -0,0 +1,17 @@
+PRNG
+====
+
+This is a simple Pseudo Random Number Generator.
+
+`prng.c` contains a simple unitary test that compares the sum of the "bytewise sum"
+of 1000 generated numbers to a hardcoded result, that is the one obtained with
+`gcc -O2` on a x86 processor, and returns 0 if the result is correct.
+
+The following commands can be run inside that folder:
+
+- `make`: produces the unitary test binaries
+  - `prng-test-gcc-x86` : binary from gcc on x86
+  - `prng-test-k1c-x86` : binary from gcc on k1c
+  - `prng-test-ccomp-x86` : binary from ccomp on k1c
+- `make test`: tests the return value of the binaries produced by gcc.
+- `make check`: tests the return value of the binary produced by CompCert.
diff --git a/test/mppa/lib/prng.c b/test/mppa/prng/prng.c
index 59ec7ca6..71de1dc3 100644
--- a/test/mppa/lib/prng.c
+++ b/test/mppa/prng/prng.c
@@ -19,8 +19,9 @@ uint64_t randlong(void){
 #ifdef __UNIT_TEST_PRNG__
 char bytewise_sum(uint64_t to_check){
     char sum = 0;
+    int i;
 
-    for (int i = 0 ; i < 8 ; i++)
+    for (i = 0 ; i < 8 ; i++)
         sum += (to_check & (uint64_t)(0xFFULL << i*8)) >> i*8;
 
     return sum;
@@ -28,15 +29,13 @@ char bytewise_sum(uint64_t to_check){
 
 int main(void){
     srand(42);
+    int i;
 
-    if (bytewise_sum(0xdeadbeefb00b1355ULL) != 91)
-        return 1;
-
-    for (int i = 0 ; i < 1000 ; i++)
+    for (i = 0 ; i < 1000 ; i++)
         randlong();
 
     uint64_t last = randlong();
 
-    return !((unsigned char)bytewise_sum(last) == 251);
+    return !((unsigned char)bytewise_sum(last) == 155);
 }
 #endif // __UNIT_TEST_PRNG__
diff --git a/test/mppa/lib/prng.h b/test/mppa/prng/prng.h
index 6abdb45a..6abdb45a 100644
--- a/test/mppa/lib/prng.h
+++ b/test/mppa/prng/prng.h
diff --git a/test/mppa/lib/types.h b/test/mppa/prng/types.h
index 584023e3..584023e3 100644
--- a/test/mppa/lib/types.h
+++ b/test/mppa/prng/types.h
diff --git a/test/mppa/sort/.gitignore b/test/mppa/sort/.gitignore
index c8f4f4e5..a8d6921c 100644
--- a/test/mppa/sort/.gitignore
+++ b/test/mppa/sort/.gitignore
@@ -1,9 +1,9 @@
-insertion-test-k1c
-insertion-test-x86
-merge-test-k1c
-selection-test-k1c
-test-k1c
-merge-test-x86
-selection-test-x86
-test-x86
-test-ccomp
+main-test-ccomp-k1c
+main-test-gcc-k1c
+main-test-gcc-x86
+merge-test-gcc-k1c
+merge-test-gcc-x86
+selection-test-gcc-k1c
+selection-test-gcc-x86
+insertion-test-gcc-k1c
+insertion-test-gcc-x86
diff --git a/test/mppa/sort/Makefile b/test/mppa/sort/Makefile
index f94fe6b8..ebbad5b5 100644
--- a/test/mppa/sort/Makefile
+++ b/test/mppa/sort/Makefile
@@ -1,82 +1,91 @@
-PRNG=../lib/prng.c
-CCOMP=../../../ccomp
-
-ALL= insertion-test-x86 insertion-test-k1c\
-     selection-test-x86 selection-test-k1c\
-     merge-test-x86     merge-test-k1c\
-     test-x86           test-k1c\
-     test-ccomp
+K1CC ?= k1-mbr-gcc
+CC ?= gcc
+CCOMP ?= ccomp
+CFLAGS ?= -O2
+SIMU ?= k1-cluster
+TIMEOUT ?= 10s
+
+K1CCPATH=$(shell which $(K1CC))
+CCPATH=$(shell which $(CC))
+CCOMPPATH=$(shell which $(CCOMP))
+SIMUPATH=$(shell which $(SIMU))
+
+PRNG=../prng/prng.c
+
+CFILES=insertion.c merge.c selection.c main.c
+
+ALL= insertion-gcc-x86 insertion-gcc-k1c insertion-ccomp-k1c\
+     selection-gcc-x86 selection-gcc-k1c selection-ccomp-k1c\
+     merge-gcc-x86 merge-gcc-k1c merge-ccomp-k1c\
+     main-gcc-x86 main-gcc-k1c main-ccomp-k1c
+
+CCOMP_OUT= insertion-ccomp-k1c.out selection-ccomp-k1c.out merge-ccomp-k1c.out\
+		   main-ccomp-k1c.out
+GCC_OUT= insertion-gcc-k1c.out selection-gcc-k1c.out merge-gcc-k1c.out\
+		   main-gcc-k1c.out
+X86_GCC_OUT= insertion-gcc-x86.out selection-gcc-x86.out merge-gcc-x86.out\
+		   main-gcc-x86.out
+STUB_OUT= .zero
 
 all: $(ALL)
 
-%-test-x86: %.c $(PRNG)
-	gcc -g -D__UNIT_TEST_$$(echo $(basename $<) | tr a-z A-Z)__ -O2 -std=c99 $^ -o $@
-
-%-test-k1c: %.c $(PRNG)
-	k1-gcc -g -D__UNIT_TEST_$$(echo $(basename $<) | tr a-z A-Z)__ -O2 -std=c99 $^ -o $@
+main-gcc-x86: $(CFILES) $(PRNG) $(CCPATH)
+	$(CC) $(CFLAGS) $(filter-out $(CCPATH),$^) -o $@
 
-test-x86: selection.c merge.c insertion.c test.c $(PRNG)
-	gcc -g -O2 -std=c99 $^ -o $@
+%-gcc-x86: %.c $(PRNG) $(CCPATH)
+	$(CC) -D__UNIT_TEST_$$(echo $(basename $<) | tr a-z A-Z)__ $(CFLAGS) $(filter-out $(CCPATH),$^) -o $@
 
-test-k1c: selection.c merge.c insertion.c test.c $(PRNG)
-	k1-gcc -g -O2 -std=c99 $^ -o $@
+main-gcc-k1c: $(CFILES) $(PRNG) $(CCPATH)
+	$(K1CC) $(CFLAGS) $(filter-out $(CCPATH),$^) -o $@
 
-%.s: %.c $(CCOMP)
-	ccomp -O2 -S $< -o $@
+%-gcc-k1c: %.c $(PRNG) $(K1CCPATH)
+	$(K1CC) -D__UNIT_TEST_$$(echo $(basename $<) | tr a-z A-Z)__ $(CFLAGS) $(filter-out $(K1CCPATH),$^) -o $@
 
-test-ccomp: selection.s merge.s insertion.s test.s $(subst .c,.s,$(PRNG))
-	k1-gcc $^ -o $@
+main-ccomp-k1c: $(CFILES) $(PRNG) $(CCOMPPATH)
+	$(CCOMP) $(CFLAGS) $(filter-out $(CCOMPPATH),$^) -o $@
 
-.PHONY:
-unittest: unittest-x86 unittest-k1c
+%-ccomp-k1c: %.c $(PRNG) $(CCOMPPATH)
+	$(CCOMP) -D__UNIT_TEST_$$(echo $(basename $<) | tr a-z A-Z)__ $(CFLAGS) $(filter-out $(CCOMPPATH),$^) -o $@
 
-.PHONY:
-check: check-x86 check-k1c
+.SECONDARY:
+%x86.out: %x86
+	ret=0; timeout $(TIMEOUT) ./$< > $@ || { ret=$$?; }; echo $$ret >> $@
 
-.PHONY:
-compc-check: test-ccomp
-	@if ! k1-cluster -- ./$<; then\
-		>&2 echo "ERROR k1c: sort $< failed";\
-	else\
-		echo "k1c: Test sort $< succeeded";\
-	fi
-
-.PHONY:
-check-x86: test-x86
-	@if ! ./$<; then\
-		>&2 echo "ERROR x86: $< failed";\
-	else\
-		echo "x86: Test $< succeeded";\
-	fi
+%k1c.out: %k1c $(SIMUPATH)
+	ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@
 
-.PHONY:
-check-k1c: test-k1c
-	@if ! k1-cluster -- ./$<; then\
-		>&2 echo "ERROR k1c: $< failed";\
-	else\
-		echo "k1c: Test $< succeeded";\
-	fi
+.zero:
+	@echo "0" > $@
 
 .PHONY:
-unittest-x86: insertion-test-x86 selection-test-x86 merge-test-x86
-	@for test in $^; do\
-		if ! ./$$test; then\
+test-x86: $(STUB_OUT) $(X86_GCC_OUT)
+	@for test in $(wordlist 2,100,$^); do\
+		if ! diff $$test $(STUB_OUT); then\
 			>&2 echo "ERROR x86: $$test failed";\
 		else\
-			echo "x86: Test $$test Succeeded";\
+			echo "GOOD x86: $$test succeeded";\
 		fi;\
 	done
 
 .PHONY:
-unittest-k1c: insertion-test-k1c selection-test-k1c merge-test-k1c
-	@for test in $^; do\
-		if ! k1-cluster -- ./$$test; then\
+test-k1c: $(STUB_OUT) $(GCC_OUT)
+	@for test in $(wordlist 2,100,$^); do\
+		if ! diff $$test $(STUB_OUT); then\
 			>&2 echo "ERROR k1c: $$test failed";\
 		else\
-			echo "k1c: Test $$test Succeeded";\
+			echo "GOOD k1c: $$test succeeded";\
 		fi;\
 	done
 
 .PHONY:
-clean:
-	rm -f $(ALL)
+test: test-x86 test-k1c
+
+.PHONY:
+check: $(STUB_OUT) $(CCOMP_OUT)
+	@for test in $(wordlist 2,100,$^); do\
+		if ! diff $$test $(STUB_OUT); then\
+			>&2 echo "ERROR k1c: $$test failed";\
+		else\
+			echo "GOOD k1c: $$test succeeded";\
+		fi;\
+	done
diff --git a/test/mppa/sort/README.md b/test/mppa/sort/README.md
new file mode 100644
index 00000000..b4c2279b
--- /dev/null
+++ b/test/mppa/sort/README.md
@@ -0,0 +1,17 @@
+PRNG
+====
+
+This is a simple Pseudo Random Number Generator.
+
+`prng.c` contains a simple unitary test that compares the sum of the "bytewise sum"
+of 1000 generated numbers to a hardcoded result, that is the one obtained with
+`gcc -O2` on a x86 processor, and returns 0 if the result is correct.
+
+The following commands can be run inside that folder:
+
+- `make`: produces the unitary test binaries
+  - `prng-test-gcc-x86` : binary from gcc on x86
+  - `prng-test-k1c-x86` : binary from gcc on k1c
+  - `prng-test-ccomp-x86` : binary from ccomp on k1c
+- `make test`: tests the return value of the binaries produced by gcc.
+- `make check`: tests the return value of the binary produced by CompCert.
diff --git a/test/mppa/sort/insertion.c b/test/mppa/sort/insertion.c
index 88093b64..bca09599 100644
--- a/test/mppa/sort/insertion.c
+++ b/test/mppa/sort/insertion.c
@@ -1,5 +1,5 @@
-#include "../lib/prng.h"
-#include "../lib/types.h"
+#include "../prng/prng.h"
+#include "../prng/types.h"
 
 #ifdef __UNIT_TEST_INSERTION__
 #define SIZE 100
@@ -14,16 +14,18 @@ void swap_ins(uint64_t *a, uint64_t *b){
 }
 
 int insert_sort(uint64_t *res, const uint64_t *T){
+    int i, j;
+
     if (SIZE <= 0)
         return -1;
 
-    for (int i = 0 ; i < SIZE ; i++)
+    for (i = 0 ; i < SIZE ; i++)
         res[i] = T[i];
 
-    for (int i = 0 ; i < SIZE-1 ; i++){
+    for (i = 0 ; i < SIZE-1 ; i++){
         if (res[i] > res[i+1]){
             swap_ins(&res[i], &res[i+1]);
-            for (int j = i ; j > 0 ; j--)
+            for (j = i ; j > 0 ; j--)
                 if (res[j-1] > res[j])
                     swap_ins(&res[j-1], &res[j]);
         }
@@ -36,9 +38,10 @@ int insert_sort(uint64_t *res, const uint64_t *T){
 int main(void){
     uint64_t T[SIZE];
     uint64_t res[SIZE];
+    int i;
     srand(42);
 
-    for (int i = 0 ; i < SIZE ; i++)
+    for (i = 0 ; i < SIZE ; i++)
         T[i] = randlong();
 
     /* Sorting the table */
@@ -46,7 +49,7 @@ int main(void){
 
     /* Computing max(T) */
     uint64_t max = T[0];
-    for (int i = 1 ; i < SIZE ; i++)
+    for (i = 1 ; i < SIZE ; i++)
         if (T[i] > max)
             max = T[i];
 
diff --git a/test/mppa/sort/test.c b/test/mppa/sort/main.c
index e5e14fef..aef419aa 100644
--- a/test/mppa/sort/test.c
+++ b/test/mppa/sort/main.c
@@ -1,5 +1,5 @@
-#include "../lib/prng.h"
-#include "../lib/types.h"
+#include "../prng/prng.h"
+#include "../prng/types.h"
 
 #include "test.h"
 #include "insertion.h"
@@ -9,9 +9,10 @@
 int main(void){
     uint64_t T[SIZE];
     uint64_t res1[SIZE], res2[SIZE], res3[SIZE];
+    int i;
     srand(42);
 
-    for (int i = 0 ; i < SIZE ; i++)
+    for (i = 0 ; i < SIZE ; i++)
         T[i] = randlong();
 
     /* insertion sort */
@@ -24,7 +25,7 @@ int main(void){
     if (merge_sort(res3, T) < 0) return -3;
 
     /* We should have: res1[i] == res2[i] == res3[i] */
-    for (int i = 0 ; i < SIZE ; i++){
+    for (i = 0 ; i < SIZE ; i++){
         if (!(res1[i] == res2[i] && res2[i] == res3[i]))
             return -4;
     }
diff --git a/test/mppa/sort/merge.c b/test/mppa/sort/merge.c
index b2d41ce3..99f8ba85 100644
--- a/test/mppa/sort/merge.c
+++ b/test/mppa/sort/merge.c
@@ -1,5 +1,5 @@
-#include "../lib/prng.h"
-#include "../lib/types.h"
+#include "../prng/prng.h"
+#include "../prng/types.h"
 
 //https://en.wikipedia.org/wiki/Merge_sort
 
@@ -15,8 +15,8 @@ int min(int a, int b){
 
 void BottomUpMerge(const uint64_t *A, int iLeft, int iRight, int iEnd, uint64_t *B)
 {
-    int i = iLeft, j = iRight;
-    for (int k = iLeft; k < iEnd; k++) {
+    int i = iLeft, j = iRight, k;
+    for (k = iLeft; k < iEnd; k++) {
         if (i < iRight && (j >= iEnd || A[i] <= A[j])) {
             B[k] = A[i];
             i = i + 1;
@@ -30,18 +30,20 @@ void BottomUpMerge(const uint64_t *A, int iLeft, int iRight, int iEnd, uint64_t
 void CopyArray(uint64_t *to, const uint64_t *from)
 {
     const int n = SIZE;
+    int i;
 
-    for(int i = 0; i < n; i++)
+    for(i = 0; i < n; i++)
         to[i] = from[i];
 }
 
 void BottomUpMergeSort(uint64_t *A, uint64_t *B)
 {
     const int n = SIZE;
+    int width, i;
 
-    for (int width = 1; width < n; width = 2 * width)
+    for (width = 1; width < n; width = 2 * width)
     {
-        for (int i = 0; i < n; i = i + 2 * width)
+        for (i = 0; i < n; i = i + 2 * width)
         {
             BottomUpMerge(A, i, min(i+width, n), min(i+2*width, n), B);
         }
@@ -50,12 +52,14 @@ void BottomUpMergeSort(uint64_t *A, uint64_t *B)
 }
 
 int merge_sort(uint64_t *res, const uint64_t *T){
+    int i;
+
     if (SIZE <= 0)
         return -1;
 
     uint64_t B[SIZE];
     uint64_t *A = res;
-    for (int i = 0 ; i < SIZE ; i++)
+    for (i = 0 ; i < SIZE ; i++)
         A[i] = T[i];
 
     BottomUpMergeSort(A, B);
@@ -67,9 +71,10 @@ int merge_sort(uint64_t *res, const uint64_t *T){
 int main(void){
     uint64_t T[SIZE];
     uint64_t res[SIZE];
+    int i;
     srand(42);
 
-    for (int i = 0 ; i < SIZE ; i++)
+    for (i = 0 ; i < SIZE ; i++)
         T[i] = randlong();
 
     /* Sorting the table */
@@ -77,7 +82,7 @@ int main(void){
 
     /* Computing max(T) */
     uint64_t max = T[0];
-    for (int i = 1 ; i < SIZE ; i++)
+    for (i = 1 ; i < SIZE ; i++)
         if (T[i] > max)
             max = T[i];
 
diff --git a/test/mppa/sort/selection.c b/test/mppa/sort/selection.c
index 89bc2c65..df4be04f 100644
--- a/test/mppa/sort/selection.c
+++ b/test/mppa/sort/selection.c
@@ -1,5 +1,5 @@
-#include "../lib/prng.h"
-#include "../lib/types.h"
+#include "../prng/prng.h"
+#include "../prng/types.h"
 
 #ifdef __UNIT_TEST_SELECTION__
 #define SIZE 100
@@ -14,15 +14,16 @@ void swap_sel(uint64_t *a, uint64_t *b){
 }
 
 int select_sort(uint64_t *res, const uint64_t *T){
+    int i, j, iMin;
+
     if (SIZE <= 0)
         return -1;
 
-    for (int i = 0 ; i < SIZE ; i++)
+    for (i = 0 ; i < SIZE ; i++)
         res[i] = T[i];
 
-    for (int j = 0 ; j < SIZE ; j++){
-        int i;
-        int iMin = j;
+    for (j = 0 ; j < SIZE ; j++){
+        iMin = j;
         for (i = j+1 ; i < SIZE ; i++)
             if (res[i] < res[iMin])
                 iMin = i;
@@ -38,17 +39,19 @@ int select_sort(uint64_t *res, const uint64_t *T){
 int main(void){
     uint64_t T[SIZE];
     uint64_t res[SIZE];
+    uint64_t max;
+    int i;
     srand(42);
 
-    for (int i = 0 ; i < SIZE ; i++)
+    for (i = 0 ; i < SIZE ; i++)
         T[i] = randlong();
 
     /* Sorting the table */
     if (select_sort(res, T) < 0) return -1;
 
     /* Computing max(T) */
-    uint64_t max = T[0];
-    for (int i = 1 ; i < SIZE ; i++)
+    max = T[0];
+    for (i = 1 ; i < SIZE ; i++)
         if (T[i] > max)
             max = T[i];
 
diff --git a/test/mppa/test.sh b/test/mppa/test.sh
new file mode 100755
index 00000000..dfeb153a
--- /dev/null
+++ b/test/mppa/test.sh
@@ -0,0 +1,6 @@
+#!/bin/bash
+# Tests the validity of the tests
+
+source do_test.sh
+
+do_test test