Reorganized the development, modularizing away machine-dependent parts.

Started to merge the ARM code generator.
Started to add support for PowerPC/EABI.
Use ocamlbuild to construct executable from Caml files.


git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@930 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e

17 files changed, 12583 insertions, 0 deletions

diff --git a/powerpc/Asm.v b/powerpc/Asm.v
new file mode 100644
index 00000000..7be155bf
--- /dev/null
+++ b/powerpc/Asm.v
@@ -0,0 +1,880 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              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.     *)
+(*                                                                     *)
+(* *********************************************************************)
+
+(** Abstract syntax and semantics for PowerPC assembly language *)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Mem.
+Require Import Events.
+Require Import Globalenvs.
+Require Import Smallstep.
+Require Import Locations.
+Require Stacklayout.
+Require Conventions.
+
+(** * Abstract syntax *)
+
+(** Integer registers, floating-point registers. *)
+
+Inductive ireg: Set :=
+  | GPR0: ireg  | GPR1: ireg  | GPR2: ireg  | GPR3: ireg
+  | GPR4: ireg  | GPR5: ireg  | GPR6: ireg  | GPR7: ireg
+  | GPR8: ireg  | GPR9: ireg  | GPR10: ireg | GPR11: ireg
+  | GPR12: ireg | GPR13: ireg | GPR14: ireg | GPR15: ireg
+  | GPR16: ireg | GPR17: ireg | GPR18: ireg | GPR19: ireg
+  | GPR20: ireg | GPR21: ireg | GPR22: ireg | GPR23: ireg
+  | GPR24: ireg | GPR25: ireg | GPR26: ireg | GPR27: ireg
+  | GPR28: ireg | GPR29: ireg | GPR30: ireg | GPR31: ireg.
+
+Inductive freg: Set :=
+  | FPR0: freg  | FPR1: freg  | FPR2: freg  | FPR3: freg
+  | FPR4: freg  | FPR5: freg  | FPR6: freg  | FPR7: freg
+  | FPR8: freg  | FPR9: freg  | FPR10: freg | FPR11: freg
+  | FPR12: freg | FPR13: freg | FPR14: freg | FPR15: freg
+  | FPR16: freg | FPR17: freg | FPR18: freg | FPR19: freg
+  | FPR20: freg | FPR21: freg | FPR22: freg | FPR23: freg
+  | FPR24: freg | FPR25: freg | FPR26: freg | FPR27: freg
+  | FPR28: freg | FPR29: freg | FPR30: freg | FPR31: freg.
+
+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.
+
+(** Symbolic constants.  Immediate operands to an arithmetic instruction
+  or an indexed memory access can be either integer literals
+  or the low or high 16 bits of a symbolic reference (the address
+  of a symbol plus a displacement).  These symbolic references are
+  resolved later by the linker.
+*)
+
+Inductive constant: Set :=
+  | Cint: int -> constant
+  | Csymbol_low: ident -> int -> constant
+  | Csymbol_high: ident -> int -> constant.
+
+(** A note on constants: while immediate operands to PowerPC
+  instructions must be representable in 16 bits (with
+  sign extension or left shift by 16 positions for some 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 PPC generator (file [PPCgen]) is
+  careful to respect this range. *)
+
+(** Bits in the condition register.  We are only interested in the
+  first 4 bits. *)
+
+Inductive crbit: Set :=
+  | CRbit_0: crbit
+  | CRbit_1: crbit
+  | CRbit_2: crbit
+  | CRbit_3: crbit.
+
+(** The instruction set.  Most instructions correspond exactly to
+  actual instructions of the PowerPC processor. See the PowerPC
+  reference manuals for more details.  Some instructions,
+  described below, are pseudo-instructions: they expand to
+  canned instruction sequences during the printing of the assembly
+  code. *)
+
+Definition label := positive.
+
+Inductive instruction : Set :=
+  | Padd: ireg -> ireg -> ireg -> instruction                 (**r integer addition *)
+  | Paddi: ireg -> ireg -> constant -> instruction            (**r add immediate *)
+  | Paddis: ireg -> ireg -> constant -> instruction           (**r add immediate high *)
+  | Paddze: ireg -> ireg -> instruction                       (**r add Carry bit *)
+  | Pallocblock: instruction                                  (**r allocate new heap block *)
+  | Pallocframe: Z -> Z -> int -> instruction                 (**r allocate new stack frame *)
+  | Pand_: ireg -> ireg -> ireg -> instruction                (**r bitwise and *)
+  | Pandc: ireg -> ireg -> ireg -> instruction                (**r bitwise and-complement *)
+  | Pandi_: ireg -> ireg -> constant -> instruction           (**r and immediate and set conditions *)
+  | Pandis_: ireg -> ireg -> constant -> instruction          (**r and immediate high and set conditions *)
+  | Pb: label -> instruction                                  (**r unconditional branch *)
+  | Pbctr: instruction                                        (**r branch to contents of register CTR *)
+  | Pbctrl: instruction                                       (**r branch to contents of CTR and link *)
+  | Pbf: crbit -> label -> instruction                        (**r branch if false *)
+  | Pbl: ident -> instruction                                 (**r branch and link *)
+  | Pbs: ident -> instruction                                 (**r branch to symbol *)
+  | Pblr: instruction                                         (**r branch to contents of register LR *)
+  | Pbt: crbit -> label -> instruction                        (**r branch if true *)
+  | Pcmplw: ireg -> ireg -> instruction                       (**r unsigned integer comparison *)
+  | Pcmplwi: ireg -> constant -> instruction                  (**r same, with immediate argument *)
+  | Pcmpw: ireg -> ireg -> instruction                        (**r signed integer comparison *)
+  | Pcmpwi: ireg -> constant -> instruction                   (**r same, with immediate argument *)
+  | Pcror: crbit -> crbit -> crbit -> instruction             (**r or between condition bits *)
+  | Pdivw: ireg -> ireg -> ireg -> instruction                (**r signed division *)
+  | Pdivwu: ireg -> ireg -> ireg -> instruction               (**r unsigned division *)
+  | Peqv: ireg -> ireg -> ireg -> instruction                 (**r bitwise not-xor *)
+  | Pextsb: ireg -> ireg -> instruction                       (**r 8-bit sign extension *)
+  | Pextsh: ireg -> ireg -> instruction                       (**r 16-bit sign extension *)
+  | Pfreeframe: int -> instruction                            (**r deallocate stack frame and restore previous frame *)
+  | Pfabs: freg -> freg -> instruction                        (**r float absolute value *)
+  | Pfadd: freg -> freg -> freg -> instruction                (**r float addition *)
+  | Pfcmpu: freg -> freg -> instruction                       (**r float comparison *)
+  | Pfcti: ireg -> freg -> instruction                        (**r float-to-signed-int conversion *)
+  | Pfctiu: ireg -> freg -> instruction                       (**r float-to-unsigned-int conversion *)
+  | Pfdiv: freg -> freg -> freg -> instruction                (**r float division *)
+  | Pfmadd: freg -> freg -> freg -> freg -> instruction       (**r float multiply-add *)
+  | Pfmr: freg -> freg -> instruction                         (**r float move *)
+  | Pfmsub: freg -> freg -> freg -> freg -> instruction       (**r float multiply-sub *)
+  | Pfmul: freg -> freg -> freg -> instruction                (**r float multiply *)
+  | Pfneg: freg -> freg -> instruction                        (**r float negation *)
+  | Pfrsp: freg -> freg -> instruction                        (**r float round to single precision *)
+  | Pfsub: freg -> freg -> freg -> instruction                (**r float subtraction *)
+  | Pictf: freg -> ireg -> instruction                        (**r int-to-float conversion *)
+  | Piuctf: freg -> ireg -> instruction                       (**r unsigned int-to-float conversion *)
+  | Plbz: ireg -> constant -> ireg -> instruction             (**r load 8-bit unsigned int *)
+  | Plbzx: ireg -> ireg -> ireg -> instruction                (**r same, with 2 index regs *)
+  | Plfd: freg -> constant -> ireg -> instruction             (**r load 64-bit float *)
+  | Plfdx: freg -> ireg -> ireg -> instruction                (**r same, with 2 index regs *)
+  | Plfs: freg -> constant -> ireg -> instruction             (**r load 32-bit float *)
+  | Plfsx: freg -> ireg -> ireg -> instruction                (**r same, with 2 index regs *)
+  | Plha: ireg -> constant -> ireg -> instruction             (**r load 16-bit signed int *)
+  | Plhax: ireg -> ireg -> ireg -> instruction                (**r same, with 2 index regs *)
+  | Plhz: ireg -> constant -> ireg -> instruction             (**r load 16-bit unsigned int *)
+  | Plhzx: ireg -> ireg -> ireg -> instruction                (**r same, with 2 index regs *)
+  | Plfi: freg -> float -> instruction                        (**r load float constant *)
+  | Plwz: ireg -> constant -> ireg -> instruction             (**r load 32-bit int *)
+  | Plwzx: ireg -> ireg -> ireg -> instruction                (**r same, with 2 index regs *)
+  | Pmfcrbit: ireg -> crbit -> instruction                    (**r move condition bit to reg *)
+  | Pmflr: ireg -> instruction                                (**r move LR to reg *)
+  | Pmr: ireg -> ireg -> instruction                          (**r integer move *)
+  | Pmtctr: ireg -> instruction                               (**r move ireg to CTR *)
+  | Pmtlr: ireg -> instruction                                (**r move ireg to LR *)
+  | Pmulli: ireg -> ireg -> constant -> instruction           (**r integer multiply immediate *)
+  | Pmullw: ireg -> ireg -> ireg -> instruction               (**r integer multiply *)
+  | Pnand: ireg -> ireg -> ireg -> instruction                (**r bitwise not-and *)
+  | Pnor: ireg -> ireg -> ireg -> instruction                 (**r bitwise not-or *)
+  | Por: ireg -> ireg -> ireg -> instruction                  (**r bitwise or *)
+  | Porc: ireg -> ireg -> ireg -> instruction                 (**r bitwise or-complement *)
+  | Pori: ireg -> ireg -> constant -> instruction             (**r or with immediate *)
+  | Poris: ireg -> ireg -> constant -> instruction            (**r or with immediate high *)
+  | Prlwinm: ireg -> ireg -> int -> int -> instruction        (**r rotate and mask *)
+  | Pslw: ireg -> ireg -> ireg -> instruction                 (**r shift left *)
+  | Psraw: ireg -> ireg -> ireg -> instruction                (**r shift right signed *)
+  | Psrawi: ireg -> ireg -> int -> instruction                (**r shift right signed immediate *)
+  | Psrw: ireg -> ireg -> ireg -> instruction                 (**r shift right unsigned *)
+  | Pstb: ireg -> constant -> ireg -> instruction             (**r store 8-bit int *)
+  | Pstbx: ireg -> ireg -> ireg -> instruction                (**r same, with 2 index regs *)
+  | Pstfd: freg -> constant -> ireg -> instruction            (**r store 64-bit float *)
+  | Pstfdx: freg -> ireg -> ireg -> instruction               (**r same, with 2 index regs *)
+  | Pstfs: freg -> constant -> ireg -> instruction            (**r store 32-bit float *)
+  | Pstfsx: freg -> ireg -> ireg -> instruction               (**r same, with 2 index regs *)
+  | Psth: ireg -> constant -> ireg -> instruction             (**r store 16-bit int *)
+  | Psthx: ireg -> ireg -> ireg -> instruction                (**r same, with 2 index regs *)
+  | Pstw: ireg -> constant -> ireg -> instruction             (**r store 32-bit int *)
+  | Pstwx: ireg -> ireg -> ireg -> instruction                (**r same, with 2 index regs *)
+  | Psubfc: ireg -> ireg -> ireg -> instruction               (**r reversed integer subtraction *)
+  | Psubfic: ireg -> ireg -> constant -> instruction          (**r integer subtraction from immediate *)
+  | Pxor: ireg -> ireg -> ireg -> instruction                 (**r bitwise xor *)
+  | Pxori: ireg -> ireg -> constant -> instruction            (**r bitwise xor with immediate *)
+  | Pxoris: ireg -> ireg -> constant -> instruction           (**r bitwise xor with immediate high *)
+  | Plabel: label -> instruction.                             (**r define a code label *)
+
+(** The pseudo-instructions are the following:
+
+- [Plabel]: define a code label at the current program point
+- [Plfi]: load a floating-point constant in a float register.
+  Expands to a float load [lfd] from an address in the constant data section
+  initialized with the floating-point constant:
+<<
+        addis   r2, 0, ha16(lbl)
+        lfd     rdst, lo16(lbl)(r2)
+        .const_data
+lbl:    .double floatcst
+        .text
+>>
+  Initialized data in the constant data section are not modeled here,
+  which is why we use a pseudo-instruction for this purpose.
+- [Pfcti]: convert a float to a signed integer.  This requires a transfer
+  via memory of a 32-bit integer from a float register to an int register,
+  which our memory model cannot express.  Expands to:
+<<
+        fctiwz  f13, rsrc
+        stfdu   f13, -8(r1)
+        lwz     rdst, 4(r1)
+        addi    r1, r1, 8
+>>
+- [Pfctiu]: convert a float to an unsigned integer.  The PowerPC way
+  to do this is to compare the argument against the floating-point
+  constant [2^31], subtract [2^31] if bigger, then convert to a signed
+  integer as above, then add back [2^31] if needed.  Expands to:
+<<
+        addis   r2, 0, ha16(lbl1)
+        lfd     f13, lo16(lbl1)(r2)
+        fcmpu   cr7, rsrc, f13
+        cror    30, 29, 30
+        beq     cr7, lbl2
+        fctiwz  f13, rsrc
+        stfdu   f13, -8(r1)
+        lwz     rdst, 4(r1)
+        b       lbl3
+lbl2:   fsub    f13, rsrc, f13
+        fctiwz  f13, f13
+        stfdu   f13, -8(r1)
+        lwz     rdst, 4(r1)
+        addis   rdst, rdst, 0x8000
+lbl3:   addi    r1, r1, 8
+        .const_data
+lbl1:   .long   0x41e00000, 0x00000000    # 2^31 in double precision
+        .text
+>>
+- [Pictf]: convert a signed integer to a float.  This requires complicated
+  bit-level manipulations of IEEE floats through mixed float and integer 
+  arithmetic over a memory word, which our memory model and axiomatization
+  of floats cannot express.  Expands to:
+<<
+        addis   r2, 0, 0x4330
+        stwu    r2, -8(r1)
+        addis   r2, rsrc, 0x8000
+        stw     r2, 4(r1)
+        addis   r2, 0, ha16(lbl)
+        lfd     f13, lo16(lbl)(r2)
+        lfd     rdst, 0(r1)
+        addi    r1, r1, 8
+        fsub    rdst, rdst, f13
+        .const_data
+lbl:    .long   0x43300000, 0x80000000
+        .text
+>>
+  (Don't worry if you do not understand this instruction sequence: intimate
+  knowledge of IEEE float arithmetic is necessary.)
+- [Piuctf]: convert an unsigned integer to a float.  The expansion is close
+  to that [Pictf], and equally obscure.
+<<
+        addis   r2, 0, 0x4330
+        stwu    r2, -8(r1)
+        stw     rsrc, 4(r1)
+        addis   r2, 0, ha16(lbl)
+        lfd     f13, lo16(lbl)(r2)
+        lfd     rdst, 0(r1)
+        addi    r1, r1, 8
+        fsub    rdst, rdst, f13
+        .const_data
+lbl:    .long   0x43300000, 0x00000000
+        .text
+>>
+- [Pallocframe lo hi ofs]: in the formal semantics, this pseudo-instruction
+  allocates a memory block with bounds [lo] and [hi], stores the value
+  of register [r1] (the stack pointer, by convention) at offset [ofs]
+  in this block, and sets [r1] to a pointer to the bottom of this
+  block.  In the printed PowerPC assembly code, this allocation
+  is just a store-decrement of register [r1], assuming that [ofs = 0]:
+<<
+        stwu    r1, (lo - hi)(r1)
+>>
+  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 ofs]: in the formal semantics, this pseudo-instruction
+  reads the word at offset [ofs] in the block pointed by [r1] (the
+  stack pointer), frees this block, and sets [r1] to the value of the
+  word at offset [ofs].  In the printed PowerPC assembly code, this
+  freeing is just a load of register [r1] relative to [r1] itself:
+<<
+        lwz     r1, ofs(r1)
+>>
+  Again, our memory model cannot comprehend that this operation
+  frees (logically) the current stack frame.
+- [Pallocheap]: in the formal semantics, this pseudo-instruction
+  allocates a heap block of size the contents of [GPR3], and leaves
+  a pointer to this block in [GPR3].  In the generated assembly code,
+  it is turned into a call to the allocation function of the run-time
+  system.
+*)
+
+Definition code := list instruction.
+Definition fundef := AST.fundef code.
+Definition program := AST.program fundef unit.
+
+(** * Operational semantics *)
+
+(** The PowerPC has a great many registers, some general-purpose, some very
+  specific.  We model only the following registers: *)
+
+Inductive preg: Set :=
+  | IR: ireg -> preg                    (**r integer registers *)
+  | FR: freg -> preg                    (**r float registers *)
+  | PC: preg                            (**r program counter *)
+  | LR: preg                            (**r link register (return address) *)
+  | CTR: preg                           (**r count register, used for some branches *)
+  | CARRY: preg                         (**r carry bit of the status register *)
+  | CR0_0: preg                         (**r bit 0 of the condition register  *)
+  | CR0_1: preg                         (**r bit 1 of the condition register  *)
+  | CR0_2: preg                         (**r bit 2 of the condition register  *)
+  | CR0_3: preg.                        (**r bit 3 of the condition register  *)
+
+Coercion IR: ireg >-> preg.
+Coercion FR: freg >-> 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).
+
+(** The semantics operates over a single mapping from registers
+  (type [preg]) to values.  We maintain (but do not enforce)
+  the convention that integer registers are mapped to values of
+  type [Tint], float registers to values of type [Tfloat],
+  and boolean registers ([CARRY], [CR0_0], etc) to either
+  [Vzero] or [Vone]. *)
+  
+Definition regset := Pregmap.t val.
+Definition genv := Genv.t fundef.
+
+Notation "a # b" := (a b) (at level 1, only parsing).
+Notation "a # b <- c" := (Pregmap.set b c a) (at level 1, b at next level).
+
+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.
+  case (peq lbl l); 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.
+
+(** Some PowerPC instructions treat register GPR0 as the integer literal 0
+  when that register is used in argument position. *)
+
+Definition gpr_or_zero (rs: regset) (r: ireg) :=
+  if ireg_eq r GPR0 then Vzero else rs#r.
+
+Variable ge: genv.
+
+Definition symbol_offset (id: ident) (ofs: int) : val :=
+  match Genv.find_symbol ge id with
+  | Some b => Vptr b ofs
+  | None => Vundef
+  end.
+
+(** The four functions below axiomatize how the linker processes
+  symbolic references [symbol + offset] and splits their
+  actual values into two 16-bit halves. *)
+
+Parameter low_half: val -> val.
+Parameter high_half: val -> 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.add (low_half (symbol_offset id ofs)) (high_half (symbol_offset id ofs))
+  = symbol_offset id ofs.
+
+(** The other axioms we take is that the results of
+  the [low_half] and [high_half] functions are of type [Tint],
+  i.e. either integers, pointers or undefined values. *)
+
+Axiom low_half_type: 
+  forall v, Val.has_type (low_half v) Tint.
+Axiom high_half_type: 
+  forall v, Val.has_type (high_half v) Tint.
+ 
+(** Armed with the [low_half] and [high_half] functions,
+  we can define the evaluation of a symbolic constant.
+  Note that for [const_high], integer constants
+  are shifted left by 16 bits, but not symbol addresses:
+  we assume (as in the [low_high_half] axioms above)
+  that the results of [high_half] are already shifted
+  (their 16 low bits are equal to 0). *)
+
+Definition const_low (c: constant) :=
+  match c with
+  | Cint n => Vint n
+  | Csymbol_low id ofs => low_half (symbol_offset id ofs)
+  | Csymbol_high id ofs => Vundef
+  end.
+
+Definition const_high (c: constant) :=
+  match c with
+  | Cint n => Vint (Int.shl n (Int.repr 16))
+  | Csymbol_low id ofs => Vundef
+  | Csymbol_high id ofs => high_half (symbol_offset id ofs)
+  end.
+
+(** The semantics is purely small-step and defined as a function
+  from the current state (a register set + a memory state)
+  to either [OK rs' m'] where [rs'] and [m'] are the updated register
+  set and memory state after execution of the instruction at [rs#PC],
+  or [Error] if the processor is stuck. *)
+
+Inductive outcome: Set :=
+  | OK: regset -> mem -> outcome
+  | Error: 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.add rs#PC Vone).
+
+Definition goto_label (c: code) (lbl: label) (rs: regset) (m: mem) :=
+  match label_pos lbl 0 c with
+  | None => Error
+  | Some pos =>
+      match rs#PC with
+      | Vptr b ofs => OK (rs#PC <- (Vptr b (Int.repr pos))) m
+      | _ => Error
+    end
+  end.
+
+(** Auxiliaries for memory accesses, in two forms: one operand
+  (plus constant offset) or two operands. *)
+
+Definition load1 (chunk: memory_chunk) (rd: preg)
+                 (cst: constant) (r1: ireg) (rs: regset) (m: mem) :=
+  match Mem.loadv chunk m (Val.add (gpr_or_zero rs r1) (const_low cst)) with
+  | None => Error
+  | Some v => OK (nextinstr (rs#rd <- v)) m
+  end.
+
+Definition load2 (chunk: memory_chunk) (rd: preg) (r1 r2: ireg)
+                 (rs: regset) (m: mem) :=
+  match Mem.loadv chunk m (Val.add rs#r1 rs#r2) with
+  | None => Error
+  | Some v => OK (nextinstr (rs#rd <- v)) m
+  end.
+
+Definition store1 (chunk: memory_chunk) (r: preg)
+                  (cst: constant) (r1: ireg) (rs: regset) (m: mem) :=
+  match Mem.storev chunk m (Val.add (gpr_or_zero rs r1) (const_low cst)) (rs#r) with
+  | None => Error
+  | Some m' => OK (nextinstr rs) m'
+  end.
+
+Definition store2 (chunk: memory_chunk) (r: preg) (r1 r2: ireg)
+                  (rs: regset) (m: mem) :=
+  match Mem.storev chunk m (Val.add rs#r1 rs#r2) (rs#r) with
+  | None => Error
+  | Some m' => OK (nextinstr rs) m'
+  end.
+
+(** Operations over condition bits. *)
+
+Definition reg_of_crbit (bit: crbit) :=
+  match bit with
+  | CRbit_0 => CR0_0
+  | CRbit_1 => CR0_1
+  | CRbit_2 => CR0_2
+  | CRbit_3 => CR0_3
+  end.
+
+Definition compare_sint (rs: regset) (v1 v2: val) :=
+  rs#CR0_0 <- (Val.cmp Clt v1 v2)
+    #CR0_1 <- (Val.cmp Cgt v1 v2)
+    #CR0_2 <- (Val.cmp Ceq v1 v2)
+    #CR0_3 <- Vundef.
+
+Definition compare_uint (rs: regset) (v1 v2: val) :=
+  rs#CR0_0 <- (Val.cmpu Clt v1 v2)
+    #CR0_1 <- (Val.cmpu Cgt v1 v2)
+    #CR0_2 <- (Val.cmpu Ceq v1 v2)
+    #CR0_3 <- Vundef.
+
+Definition compare_float (rs: regset) (v1 v2: val) :=
+  rs#CR0_0 <- (Val.cmpf Clt v1 v2)
+    #CR0_1 <- (Val.cmpf Cgt v1 v2)
+    #CR0_2 <- (Val.cmpf Ceq v1 v2)
+    #CR0_3 <- Vundef.
+
+Definition val_cond_reg (rs: regset) :=
+  Val.or (Val.shl rs#CR0_0 (Vint (Int.repr 31)))
+  (Val.or (Val.shl rs#CR0_1 (Vint (Int.repr 30)))
+   (Val.or (Val.shl rs#CR0_2 (Vint (Int.repr 29)))
+            (Val.shl rs#CR0_3 (Vint (Int.repr 28))))).
+
+(** Execution of a single instruction [i] in initial state
+    [rs] and [m].  Return updated state.  For instructions
+    that correspond to actual PowerPC instructions, the cases are
+    straightforward transliterations of the informal descriptions
+    given in the PowerPC reference manuals.  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 PPC code
+    we generate cannot use those registers to hold values that
+    must survive the execution of the pseudo-instruction.
+*)
+
+Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome :=
+  match i with
+  | Padd rd r1 r2 =>
+      OK (nextinstr (rs#rd <- (Val.add rs#r1 rs#r2))) m
+  | Paddi rd r1 cst =>
+      OK (nextinstr (rs#rd <- (Val.add (gpr_or_zero rs r1) (const_low cst)))) m
+  | Paddis rd r1 cst =>
+      OK (nextinstr (rs#rd <- (Val.add (gpr_or_zero rs r1) (const_high cst)))) m
+  | Paddze rd r1 =>
+      OK (nextinstr (rs#rd <- (Val.add rs#r1 rs#CARRY))) m
+  | Pallocblock =>
+      match rs#GPR3 with
+      | Vint n =>
+          let (m', b) := Mem.alloc m 0 (Int.signed n) in
+          OK (nextinstr (rs#GPR3 <- (Vptr b Int.zero)
+                           #LR <- (Val.add rs#PC Vone))) m'
+      | _ => Error
+      end
+  | Pallocframe lo hi ofs =>
+      let (m1, stk) := Mem.alloc m lo hi in
+      let sp := Vptr stk (Int.repr lo) in
+      match Mem.storev Mint32 m1 (Val.add sp (Vint ofs)) rs#GPR1 with
+      | None => Error
+      | Some m2 => OK (nextinstr (rs#GPR1 <- sp #GPR12 <- Vundef)) m2
+      end
+  | Pand_ rd r1 r2 =>
+      let v := Val.and rs#r1 rs#r2 in
+      OK (nextinstr (compare_sint (rs#rd <- v) v Vzero)) m
+  | Pandc rd r1 r2 =>
+      OK (nextinstr (rs#rd <- (Val.and rs#r1 (Val.notint rs#r2)))) m
+  | Pandi_ rd r1 cst =>
+      let v := Val.and rs#r1 (const_low cst) in
+      OK (nextinstr (compare_sint (rs#rd <- v) v Vzero)) m
+  | Pandis_ rd r1 cst =>
+      let v := Val.and rs#r1 (const_high cst) in
+      OK (nextinstr (compare_sint (rs#rd <- v) v Vzero)) m
+  | Pb lbl =>
+      goto_label c lbl rs m
+  | Pbctr =>
+      OK (rs#PC <- (rs#CTR)) m
+  | Pbctrl =>
+      OK (rs#LR <- (Val.add rs#PC Vone) #PC <- (rs#CTR)) m
+  | Pbf bit lbl =>
+      match rs#(reg_of_crbit bit) with
+      | Vint n => if Int.eq n Int.zero then goto_label c lbl rs m else OK (nextinstr rs) m
+      | _ => Error
+      end
+  | Pbl ident =>
+      OK (rs#LR <- (Val.add rs#PC Vone) #PC <- (symbol_offset ident Int.zero)) m
+  | Pbs ident =>
+      OK (rs#PC <- (symbol_offset ident Int.zero)) m
+  | Pblr =>
+      OK (rs#PC <- (rs#LR)) m
+  | Pbt bit lbl =>
+      match rs#(reg_of_crbit bit) with
+      | Vint n => if Int.eq n Int.zero then OK (nextinstr rs) m else goto_label c lbl rs m
+      | _ => Error
+      end
+  | Pcmplw r1 r2 =>
+      OK (nextinstr (compare_uint rs rs#r1 rs#r2)) m
+  | Pcmplwi r1 cst =>
+      OK (nextinstr (compare_uint rs rs#r1 (const_low cst))) m
+  | Pcmpw r1 r2 =>
+      OK (nextinstr (compare_sint rs rs#r1 rs#r2)) m
+  | Pcmpwi r1 cst =>
+      OK (nextinstr (compare_sint rs rs#r1 (const_low cst))) m
+  | Pcror bd b1 b2 =>
+      OK (nextinstr (rs#(reg_of_crbit bd) <- (Val.or rs#(reg_of_crbit b1) rs#(reg_of_crbit b2)))) m
+  | Pdivw rd r1 r2 =>
+      OK (nextinstr (rs#rd <- (Val.divs rs#r1 rs#r2))) m
+  | Pdivwu rd r1 r2 =>
+      OK (nextinstr (rs#rd <- (Val.divu rs#r1 rs#r2))) m
+  | Peqv rd r1 r2 =>
+      OK (nextinstr (rs#rd <- (Val.notint (Val.xor rs#r1 rs#r2)))) m
+  | Pextsb rd r1 =>
+      OK (nextinstr (rs#rd <- (Val.sign_ext 8 rs#r1))) m
+  | Pextsh rd r1 =>
+      OK (nextinstr (rs#rd <- (Val.sign_ext 16 rs#r1))) m
+  | Pfreeframe ofs =>
+      match Mem.loadv Mint32 m (Val.add rs#GPR1 (Vint ofs)) with
+      | None => Error
+      | Some v =>
+          match rs#GPR1 with
+          | Vptr stk ofs => OK (nextinstr (rs#GPR1 <- v)) (Mem.free m stk)
+          | _ => Error
+          end
+      end
+  | Pfabs rd r1 =>
+      OK (nextinstr (rs#rd <- (Val.absf rs#r1))) m
+  | Pfadd rd r1 r2 =>
+      OK (nextinstr (rs#rd <- (Val.addf rs#r1 rs#r2))) m
+  | Pfcmpu r1 r2 =>
+      OK (nextinstr (compare_float rs rs#r1 rs#r2)) m
+  | Pfcti rd r1 =>
+      OK (nextinstr (rs#rd <- (Val.intoffloat rs#r1) #FPR13 <- Vundef)) m
+  | Pfctiu rd r1 =>
+      OK (nextinstr (rs#rd <- (Val.intuoffloat rs#r1) #FPR13 <- Vundef)) m
+  | Pfdiv rd r1 r2 =>
+      OK (nextinstr (rs#rd <- (Val.divf rs#r1 rs#r2))) m
+  | Pfmadd rd r1 r2 r3 =>
+      OK (nextinstr (rs#rd <- (Val.addf (Val.mulf rs#r1 rs#r2) rs#r3))) m
+  | Pfmr rd r1 =>
+      OK (nextinstr (rs#rd <- (rs#r1))) m
+  | Pfmsub rd r1 r2 r3 =>
+      OK (nextinstr (rs#rd <- (Val.subf (Val.mulf rs#r1 rs#r2) rs#r3))) m
+  | Pfmul rd r1 r2 =>
+      OK (nextinstr (rs#rd <- (Val.mulf rs#r1 rs#r2))) m
+  | Pfneg rd r1 =>
+      OK (nextinstr (rs#rd <- (Val.negf rs#r1))) m
+  | Pfrsp rd r1 =>
+      OK (nextinstr (rs#rd <- (Val.singleoffloat rs#r1))) m
+  | Pfsub rd r1 r2 =>
+      OK (nextinstr (rs#rd <- (Val.subf rs#r1 rs#r2))) m
+  | Pictf rd r1 =>
+      OK (nextinstr (rs#rd <- (Val.floatofint rs#r1) #GPR12 <- Vundef #FPR13 <- Vundef)) m
+  | Piuctf rd r1 =>
+      OK (nextinstr (rs#rd <- (Val.floatofintu rs#r1) #GPR12 <- Vundef #FPR13 <- Vundef)) m
+  | Plbz rd cst r1 =>
+      load1 Mint8unsigned rd cst r1 rs m
+  | Plbzx rd r1 r2 =>
+      load2 Mint8unsigned rd r1 r2 rs m
+  | Plfd rd cst r1 =>
+      load1 Mfloat64 rd cst r1 rs m
+  | Plfdx rd r1 r2 =>
+      load2 Mfloat64 rd r1 r2 rs m
+  | Plfs rd cst r1 =>
+      load1 Mfloat32 rd cst r1 rs m
+  | Plfsx rd r1 r2 =>
+      load2 Mfloat32 rd r1 r2 rs m
+  | Plha rd cst r1 =>
+      load1 Mint16signed rd cst r1 rs m
+  | Plhax rd r1 r2 =>
+      load2 Mint16signed rd r1 r2 rs m
+  | Plhz rd cst r1 =>
+      load1 Mint16unsigned rd cst r1 rs m
+  | Plhzx rd r1 r2 =>
+      load2 Mint16unsigned rd r1 r2 rs m
+  | Plfi rd f =>
+      OK (nextinstr (rs#rd <- (Vfloat f) #GPR12 <- Vundef)) m
+  | Plwz rd cst r1 =>
+      load1 Mint32 rd cst r1 rs m
+  | Plwzx rd r1 r2 =>
+      load2 Mint32 rd r1 r2 rs m
+  | Pmfcrbit rd bit =>
+      OK (nextinstr (rs#rd <- (rs#(reg_of_crbit bit)))) m
+  | Pmflr rd =>
+      OK (nextinstr (rs#rd <- (rs#LR))) m
+  | Pmr rd r1 =>
+      OK (nextinstr (rs#rd <- (rs#r1))) m
+  | Pmtctr r1 =>
+      OK (nextinstr (rs#CTR <- (rs#r1))) m
+  | Pmtlr r1 =>
+      OK (nextinstr (rs#LR <- (rs#r1))) m
+  | Pmulli rd r1 cst =>
+      OK (nextinstr (rs#rd <- (Val.mul rs#r1 (const_low cst)))) m
+  | Pmullw rd r1 r2 =>
+      OK (nextinstr (rs#rd <- (Val.mul rs#r1 rs#r2))) m
+  | Pnand rd r1 r2 =>
+      OK (nextinstr (rs#rd <- (Val.notint (Val.and rs#r1 rs#r2)))) m
+  | Pnor rd r1 r2 =>
+      OK (nextinstr (rs#rd <- (Val.notint (Val.or rs#r1 rs#r2)))) m
+  | Por rd r1 r2 =>
+      OK (nextinstr (rs#rd <- (Val.or rs#r1 rs#r2))) m
+  | Porc rd r1 r2 =>
+      OK (nextinstr (rs#rd <- (Val.or rs#r1 (Val.notint rs#r2)))) m
+  | Pori rd r1 cst =>
+      OK (nextinstr (rs#rd <- (Val.or rs#r1 (const_low cst)))) m
+  | Poris rd r1 cst =>
+      OK (nextinstr (rs#rd <- (Val.or rs#r1 (const_high cst)))) m
+  | Prlwinm rd r1 amount mask =>
+      OK (nextinstr (rs#rd <- (Val.rolm rs#r1 amount mask))) m
+  | Pslw rd r1 r2 =>
+      OK (nextinstr (rs#rd <- (Val.shl rs#r1 rs#r2))) m
+  | Psraw rd r1 r2 =>
+      OK (nextinstr (rs#rd <- (Val.shr rs#r1 rs#r2) #CARRY <- (Val.shr_carry rs#r1 rs#r2))) m
+  | Psrawi rd r1 n =>
+      OK (nextinstr (rs#rd <- (Val.shr rs#r1 (Vint n)) #CARRY <- (Val.shr_carry rs#r1 (Vint n)))) m
+  | Psrw rd r1 r2 =>
+      OK (nextinstr (rs#rd <- (Val.shru rs#r1 rs#r2))) m
+  | Pstb rd cst r1 =>
+      store1 Mint8unsigned rd cst r1 rs m
+  | Pstbx rd r1 r2 =>
+      store2 Mint8unsigned rd r1 r2 rs m
+  | Pstfd rd cst r1 =>
+      store1 Mfloat64 rd cst r1 rs m
+  | Pstfdx rd r1 r2 =>
+      store2 Mfloat64 rd r1 r2 rs m
+  | Pstfs rd cst r1 =>
+      store1 Mfloat32 rd cst r1 rs m
+  | Pstfsx rd r1 r2 =>
+      store2 Mfloat32 rd r1 r2 rs m
+  | Psth rd cst r1 =>
+      store1 Mint16unsigned rd cst r1 rs m
+  | Psthx rd r1 r2 =>
+      store2 Mint16unsigned rd r1 r2 rs m
+  | Pstw rd cst r1 =>
+      store1 Mint32 rd cst r1 rs m
+  | Pstwx rd r1 r2 =>
+      store2 Mint32 rd r1 r2 rs m
+  | Psubfc rd r1 r2 =>
+      OK (nextinstr (rs#rd <- (Val.sub rs#r2 rs#r1) #CARRY <- Vundef)) m
+  | Psubfic rd r1 cst =>
+      OK (nextinstr (rs#rd <- (Val.sub (const_low cst) rs#r1) #CARRY <- Vundef)) m
+  | Pxor rd r1 r2 =>
+      OK (nextinstr (rs#rd <- (Val.xor rs#r1 rs#r2))) m
+  | Pxori rd r1 cst =>
+      OK (nextinstr (rs#rd <- (Val.xor rs#r1 (const_low cst)))) m
+  | Pxoris rd r1 cst =>
+      OK (nextinstr (rs#rd <- (Val.xor rs#r1 (const_high cst)))) m
+  | Plabel lbl =>
+      OK (nextinstr rs) m
+  end.
+
+(** Translation of the LTL/Linear/Mach view of machine registers
+  to the PPC view.  PPC has two different types for registers
+  (integer and float) while LTL et al have only one.  The
+  [ireg_of] and [freg_of] are therefore partial in principle.
+  To keep things simpler, we make them return nonsensical
+  results when applied to a LTL register of the wrong type.
+  The proof in [Asmgenproof] will show that this never happens.
+
+  Note that no LTL register maps to [GPR12] nor [FPR13].
+  These two registers are reserved as temporaries, to be used
+  by the generated PPC code.  *)
+
+Definition ireg_of (r: mreg) : ireg :=
+  match r with
+  | R3 => GPR3  | R4 => GPR4  | R5 => GPR5  | R6 => GPR6
+  | R7 => GPR7  | R8 => GPR8  | R9 => GPR9  | R10 => GPR10
+  | 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 | R31 => GPR31
+  | IT1 => GPR11 | IT2 => GPR0
+  | _ => GPR0 (* should not happen *)
+  end.
+
+Definition freg_of (r: mreg) : freg :=
+  match r with
+  | F1 => FPR1  | F2 => FPR2  | F3 => FPR3  | F4 => FPR4
+  | F5 => FPR5  | F6 => FPR6  | F7 => FPR7  | F8 => FPR8
+  | F9 => FPR9  | F10 => FPR10 | F14 => FPR14 | F15 => FPR15
+  | F16 => FPR16 | F17 => FPR17 | F18 => FPR18 | F19 => FPR19
+  | F20 => FPR20 | F21 => FPR21 | F22 => FPR22 | F23 => FPR23
+  | F24 => FPR24 | F25 => FPR25 | F26 => FPR26 | F27 => FPR27
+  | F28 => FPR28 | F29 => FPR29 | F30 => FPR30 | F31 => FPR31
+  | FT1 => FPR0 | FT2 => FPR11 | FT3 => FPR12
+  | _ => FPR0 (* should not happen *)
+  end.
+
+Definition preg_of (r: mreg) :=
+  match mreg_type r with
+  | Tint => IR (ireg_of r)
+  | Tfloat => FR (freg_of r)
+  end.
+
+(** Extract the values of the arguments of an external call.
+    We exploit the calling conventions from module [Conventions], except that
+    we use PPC 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_int_stack: forall ofs bofs v,
+      bofs = Stacklayout.fe_ofs_arg + 4 * ofs ->
+      Mem.loadv Mint32 m (Val.add (rs (IR GPR1)) (Vint (Int.repr bofs))) = Some v ->
+      extcall_arg rs m (S (Outgoing ofs Tint)) v
+  | extcall_arg_float_stack: forall ofs bofs v,
+      bofs = Stacklayout.fe_ofs_arg + 4 * ofs ->
+      Mem.loadv Mfloat64 m (Val.add (rs (IR GPR1)) (Vint (Int.repr bofs))) = Some v ->
+      extcall_arg rs m (S (Outgoing ofs Tfloat)) v.
+
+Inductive extcall_args (rs: regset) (m: mem): list loc -> list val -> Prop :=
+  | extcall_args_nil:
+      extcall_args rs m nil nil
+  | extcall_args_cons: forall l1 ll v1 vl,
+      extcall_arg rs m l1 v1 -> extcall_args rs m ll vl ->
+      extcall_args rs m (l1 :: ll) (v1 :: vl).
+
+Definition extcall_arguments
+    (rs: regset) (m: mem) (sg: signature) (args: list val) : Prop :=
+  extcall_args rs m (Conventions.loc_arguments sg) args.
+
+Definition loc_external_result (sg: signature) : preg :=
+  preg_of (Conventions.loc_result sg).
+
+(** Execution of the instruction at [rs#PC]. *)
+
+Inductive state: Set :=
+  | State: regset -> mem -> state.
+
+Inductive step: state -> trace -> state -> Prop :=
+  | exec_step_internal:
+      forall b ofs c i rs m rs' m',
+      rs PC = Vptr b ofs ->
+      Genv.find_funct_ptr ge b = Some (Internal c) ->
+      find_instr (Int.unsigned ofs) c = Some i ->
+      exec_instr c i rs m = OK rs' m' ->
+      step (State rs m) E0 (State rs' m')
+  | exec_step_external:
+      forall b ef args res rs m t rs',
+      rs PC = Vptr b Int.zero ->
+      Genv.find_funct_ptr ge b = Some (External ef) ->
+      event_match ef args t res ->
+      extcall_arguments rs m ef.(ef_sig) args ->
+      rs' = (rs#(loc_external_result ef.(ef_sig)) <- res
+               #PC <- (rs LR)) ->
+      step (State rs m) t (State rs' m).
+
+End RELSEM.
+
+(** Execution of whole programs. *)
+
+Inductive initial_state (p: program): state -> Prop :=
+  | initial_state_intro:
+      let ge := Genv.globalenv p in
+      let m0 := Genv.init_mem p in
+      let rs0 :=
+        (Pregmap.init Vundef)
+        # PC <- (symbol_offset ge p.(prog_main) Int.zero)
+        # LR <- Vzero
+        # GPR1 <- (Vptr Mem.nullptr Int.zero) in
+      initial_state p (State rs0 m0).
+
+Inductive final_state: state -> int -> Prop :=
+  | final_state_intro: forall rs m r,
+      rs#PC = Vzero ->
+      rs#GPR3 = Vint r ->
+      final_state (State rs m) r.
+      
+Definition exec_program (p: program) (beh: program_behavior) : Prop :=
+  program_behaves step (initial_state p) final_state (Genv.globalenv p) beh.
+
diff --git a/powerpc/Asmgen.v b/powerpc/Asmgen.v
new file mode 100644
index 00000000..2ddaa6d0
--- /dev/null
+++ b/powerpc/Asmgen.v
@@ -0,0 +1,510 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              The Compcert verified compiler                         *)
+(*                                                                     *)
+(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
+(*                                                                     *)
+(*  Copyright Institut National de Recherche en Informatique et en     *)
+(*  Automatique.  All rights reserved.  This file is distributed       *)
+(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
+(*                                                                     *)
+(* *********************************************************************)
+
+(** Translation from Mach to PPC. *)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import Errors.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Mem.
+Require Import Globalenvs.
+Require Import Op.
+Require Import Locations.
+Require Import Mach.
+Require Import Asm.
+
+(** Decomposition of integer constants.  As noted in file [Asm],
+  immediate arguments to PowerPC instructions must fit into 16 bits,
+  and are interpreted after zero extension, sign extension, or
+  left shift by 16 bits, depending on the instruction.  Integer
+  constants that do not fit must be synthesized using two
+  processor instructions.  The following functions decompose
+  arbitrary 32-bit integers into two 16-bit halves (high and low
+  halves).  They satisfy the following properties:
+- [low_u n] is an unsigned 16-bit integer;
+- [low_s n] is a signed 16-bit integer;
+- [(high_u n) << 16 | low_u n] equals [n];
+- [(high_s n) << 16 + low_s n] equals [n].
+*)
+
+Definition low_u (n: int) := Int.and n (Int.repr 65535).
+Definition high_u (n: int) := Int.shru n (Int.repr 16).
+Definition low_s (n: int) := Int.sign_ext 16 n.
+Definition high_s (n: int) := Int.shru (Int.sub n (low_s n)) (Int.repr 16).
+
+(** Smart constructors for arithmetic operations involving
+  a 32-bit integer constant.  Depending on whether the
+  constant fits in 16 bits or not, one or several instructions
+  are generated as required to perform the operation
+  and prepended to the given instruction sequence [k]. *)
+
+Definition loadimm (r: ireg) (n: int) (k: code) :=
+  if Int.eq (high_s n) Int.zero then
+    Paddi r GPR0 (Cint n) :: k
+  else if Int.eq (low_s n) Int.zero then
+    Paddis r GPR0 (Cint (high_s n)) :: k
+  else
+    Paddis r GPR0 (Cint (high_u n)) ::
+    Pori r r (Cint (low_u n)) :: k.
+
+Definition addimm_1 (r1 r2: ireg) (n: int) (k: code) :=
+  if Int.eq (high_s n) Int.zero then
+    Paddi r1 r2 (Cint n) :: k
+  else if Int.eq (low_s n) Int.zero then
+    Paddis r1 r2 (Cint (high_s n)) :: k
+  else
+    Paddis r1 r2 (Cint (high_s n)) ::
+    Paddi r1 r1 (Cint (low_s n)) :: k.
+
+Definition addimm_2 (r1 r2: ireg) (n: int) (k: code) :=
+  loadimm GPR12 n (Padd r1 r2 GPR12 :: k).
+
+Definition addimm (r1 r2: ireg) (n: int) (k: code) :=
+  if ireg_eq r1 GPR0 then
+    addimm_2 r1 r2 n k
+  else if ireg_eq r2 GPR0 then
+    addimm_2 r1 r2 n k
+  else
+    addimm_1 r1 r2 n k.
+
+Definition andimm (r1 r2: ireg) (n: int) (k: code) :=
+  if Int.eq (high_u n) Int.zero then
+    Pandi_ r1 r2 (Cint n) :: k
+  else if Int.eq (low_u n) Int.zero then
+    Pandis_ r1 r2 (Cint (high_u n)) :: k
+  else
+    loadimm GPR12 n (Pand_ r1 r2 GPR12 :: k).
+
+Definition orimm (r1 r2: ireg) (n: int) (k: code) :=
+  if Int.eq (high_u n) Int.zero then
+    Pori r1 r2 (Cint n) :: k
+  else if Int.eq (low_u n) Int.zero then
+    Poris r1 r2 (Cint (high_u n)) :: k
+  else
+    Poris r1 r2 (Cint (high_u n)) ::
+    Pori r1 r1 (Cint (low_u n)) :: k.
+
+Definition xorimm (r1 r2: ireg) (n: int) (k: code) :=
+  if Int.eq (high_u n) Int.zero then
+    Pxori r1 r2 (Cint n) :: k
+  else if Int.eq (low_u n) Int.zero then
+    Pxoris r1 r2 (Cint (high_u n)) :: k
+  else
+    Pxoris r1 r2 (Cint (high_u n)) ::
+    Pxori r1 r1 (Cint (low_u n)) :: k.
+
+(** Smart constructors for indexed loads and stores,
+  where the address is the contents of a register plus
+  an integer literal. *)
+
+Definition loadind_aux (base: ireg) (ofs: int) (ty: typ) (dst: mreg) :=
+  match ty with
+  | Tint => Plwz (ireg_of dst) (Cint ofs) base
+  | Tfloat => Plfd (freg_of dst) (Cint ofs) base
+  end.
+
+Definition loadind (base: ireg) (ofs: int) (ty: typ) (dst: mreg) (k: code) :=
+  if Int.eq (high_s ofs) Int.zero then
+    loadind_aux base ofs ty dst :: k
+  else
+    Paddis GPR12 base (Cint (high_s ofs)) ::
+    loadind_aux GPR12 (low_s ofs) ty dst :: k.
+  
+Definition storeind_aux (src: mreg) (base: ireg) (ofs: int) (ty: typ) :=
+  match ty with
+  | Tint => Pstw (ireg_of src) (Cint ofs) base
+  | Tfloat => Pstfd (freg_of src) (Cint ofs) base
+  end.
+
+Definition storeind (src: mreg) (base: ireg) (ofs: int) (ty: typ) (k: code) :=
+  if Int.eq (high_s ofs) Int.zero then
+    storeind_aux src base ofs ty :: k
+  else
+    Paddis GPR12 base (Cint (high_s ofs)) ::
+    storeind_aux src GPR12 (low_s ofs) ty :: k.
+  
+(** Constructor for a floating-point comparison.  The PowerPC has
+  a single [fcmpu] instruction to compare floats, which sets
+  bits 0, 1 and 2 of the condition register to reflect ``less'',
+  ``greater'' and ``equal'' conditions, respectively.
+  The ``less or equal'' and ``greater or equal'' conditions must be
+  synthesized by a [cror] instruction that computes the logical ``or''
+  of the corresponding two conditions. *)
+
+Definition floatcomp (cmp: comparison) (r1 r2: freg) (k: code) :=
+  Pfcmpu r1 r2 ::
+  match cmp with
+  | Cle => Pcror CRbit_3 CRbit_2 CRbit_0 :: k
+  | Cge => Pcror CRbit_3 CRbit_2 CRbit_1 :: k
+  | _ => k
+  end.
+
+(** Translation of a condition.  Prepends to [k] the instructions
+  that evaluate the condition and leave its boolean result in one of
+  the bits of the condition register.  The bit in question is
+  determined by the [crbit_for_cond] function. *)
+
+Definition transl_cond
+              (cond: condition) (args: list mreg) (k: code) :=
+  match cond, args with
+  | Ccomp c, a1 :: a2 :: nil =>
+      Pcmpw (ireg_of a1) (ireg_of a2) :: k
+  | Ccompu c, a1 :: a2 :: nil =>
+      Pcmplw (ireg_of a1) (ireg_of a2) :: k
+  | Ccompimm c n, a1 :: nil =>
+      if Int.eq (high_s n) Int.zero then
+        Pcmpwi (ireg_of a1) (Cint n) :: k
+      else
+        loadimm GPR12 n (Pcmpw (ireg_of a1) GPR12 :: k)
+  | Ccompuimm c n, a1 :: nil =>
+      if Int.eq (high_u n) Int.zero then
+        Pcmplwi (ireg_of a1) (Cint n) :: k
+      else
+        loadimm GPR12 n (Pcmplw (ireg_of a1) GPR12 :: k)
+  | Ccompf cmp, a1 :: a2 :: nil =>
+      floatcomp cmp (freg_of a1) (freg_of a2) k
+  | Cnotcompf cmp, a1 :: a2 :: nil =>
+      floatcomp cmp (freg_of a1) (freg_of a2) k
+  | Cmaskzero n, a1 :: nil =>
+      andimm GPR12 (ireg_of a1) n k
+  | Cmasknotzero n, a1 :: nil =>
+      andimm GPR12 (ireg_of a1) n k
+  | _, _ =>
+     k (**r never happens for well-typed code *)
+  end.
+
+(*  CRbit_0 = Less
+    CRbit_1 = Greater
+    CRbit_2 = Equal
+    CRbit_3 = Other *)
+
+Definition crbit_for_icmp (cmp: comparison) :=
+  match cmp with
+  | Ceq => (CRbit_2, true)
+  | Cne => (CRbit_2, false)
+  | Clt => (CRbit_0, true)
+  | Cle => (CRbit_1, false)
+  | Cgt => (CRbit_1, true)
+  | Cge => (CRbit_0, false)
+  end.
+
+Definition crbit_for_fcmp (cmp: comparison) :=
+  match cmp with
+  | Ceq => (CRbit_2, true)
+  | Cne => (CRbit_2, false)
+  | Clt => (CRbit_0, true)
+  | Cle => (CRbit_3, true)
+  | Cgt => (CRbit_1, true)
+  | Cge => (CRbit_3, true)
+  end.
+
+Definition crbit_for_cond (cond: condition) :=
+  match cond with
+  | Ccomp cmp => crbit_for_icmp cmp
+  | Ccompu cmp => crbit_for_icmp cmp
+  | Ccompimm cmp n => crbit_for_icmp cmp
+  | Ccompuimm cmp n => crbit_for_icmp cmp
+  | Ccompf cmp => crbit_for_fcmp cmp
+  | Cnotcompf cmp => let p := crbit_for_fcmp cmp in (fst p, negb (snd p))
+  | Cmaskzero n => (CRbit_2, true)
+  | Cmasknotzero n => (CRbit_2, false)
+  end.
+
+(** Translation of the arithmetic operation [r <- op(args)].
+  The corresponding instructions are prepended to [k]. *)
+
+Definition transl_op
+              (op: operation) (args: list mreg) (r: mreg) (k: code) :=
+  match op, args with
+  | Omove, a1 :: nil =>
+      match mreg_type a1 with
+      | Tint => Pmr (ireg_of r) (ireg_of a1) :: k
+      | Tfloat => Pfmr (freg_of r) (freg_of a1) :: k
+      end
+  | Ointconst n, nil =>
+      loadimm (ireg_of r) n k
+  | Ofloatconst f, nil =>
+      Plfi (freg_of r) f :: k
+  | Oaddrsymbol s ofs, nil =>
+      Paddis GPR12 GPR0 (Csymbol_high s ofs) ::
+      Paddi (ireg_of r) GPR12 (Csymbol_low s ofs) :: k
+  | Oaddrstack n, nil =>
+      addimm (ireg_of r) GPR1 n k
+  | Ocast8signed, a1 :: nil =>
+      Pextsb (ireg_of r) (ireg_of a1) :: k
+  | Ocast8unsigned, a1 :: nil =>
+      Prlwinm (ireg_of r) (ireg_of a1) Int.zero (Int.repr 255) :: k
+  | Ocast16signed, a1 :: nil =>
+      Pextsh (ireg_of r) (ireg_of a1) :: k
+  | Ocast16unsigned, a1 :: nil =>
+      Prlwinm (ireg_of r) (ireg_of a1) Int.zero (Int.repr 65535) :: k
+  | Oadd, a1 :: a2 :: nil =>
+      Padd (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+  | Oaddimm n, a1 :: nil =>
+      addimm (ireg_of r) (ireg_of a1) n k
+  | Osub, a1 :: a2 :: nil =>
+      Psubfc (ireg_of r) (ireg_of a2) (ireg_of a1) :: k
+  | Osubimm n, a1 :: nil =>
+      if Int.eq (high_s n) Int.zero then
+        Psubfic (ireg_of r) (ireg_of a1) (Cint n) :: k
+      else
+        loadimm GPR12 n (Psubfc (ireg_of r) (ireg_of a1) GPR12 :: k)
+  | Omul, a1 :: a2 :: nil =>
+      Pmullw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+  | Omulimm n, a1 :: nil =>
+      if Int.eq (high_s n) Int.zero then
+        Pmulli (ireg_of r) (ireg_of a1) (Cint n) :: k
+      else
+        loadimm GPR12 n (Pmullw (ireg_of r) (ireg_of a1) GPR12 :: k)
+  | Odiv, a1 :: a2 :: nil =>
+      Pdivw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+  | Odivu, a1 :: a2 :: nil =>
+      Pdivwu (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+  | Oand, a1 :: a2 :: nil =>
+      Pand_ (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+  | Oandimm n, a1 :: nil =>
+      andimm (ireg_of r) (ireg_of a1) n k
+  | Oor, a1 :: a2 :: nil =>
+      Por (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+  | Oorimm n, a1 :: nil =>
+      orimm (ireg_of r) (ireg_of a1) n k
+  | Oxor, a1 :: a2 :: nil =>
+      Pxor (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+  | Oxorimm n, a1 :: nil =>
+      xorimm (ireg_of r) (ireg_of a1) n k
+  | Onand, a1 :: a2 :: nil =>
+      Pnand (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+  | Onor, a1 :: a2 :: nil =>
+      Pnor (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+  | Onxor, a1 :: a2 :: nil =>
+      Peqv (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+  | Oshl, a1 :: a2 :: nil =>
+      Pslw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+  | Oshr, a1 :: a2 :: nil =>
+      Psraw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+  | Oshrimm n, a1 :: nil =>
+      Psrawi (ireg_of r) (ireg_of a1) n :: k
+  | Oshrximm n, a1 :: nil =>
+      Psrawi (ireg_of r) (ireg_of a1) n ::
+      Paddze (ireg_of r) (ireg_of r) :: k
+  | Oshru, a1 :: a2 :: nil =>
+      Psrw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k
+  | Orolm amount mask, a1 :: nil =>
+      Prlwinm (ireg_of r) (ireg_of a1) amount mask :: k
+  | Onegf, a1 :: nil =>
+      Pfneg (freg_of r) (freg_of a1) :: k
+  | Oabsf, a1 :: nil =>
+      Pfabs (freg_of r) (freg_of a1) :: k
+  | Oaddf, a1 :: a2 :: nil =>
+      Pfadd (freg_of r) (freg_of a1) (freg_of a2) :: k
+  | Osubf, a1 :: a2 :: nil =>
+      Pfsub (freg_of r) (freg_of a1) (freg_of a2) :: k
+  | Omulf, a1 :: a2 :: nil =>
+      Pfmul (freg_of r) (freg_of a1) (freg_of a2) :: k
+  | Odivf, a1 :: a2 :: nil =>
+      Pfdiv (freg_of r) (freg_of a1) (freg_of a2) :: k
+  | Omuladdf, a1 :: a2 :: a3 :: nil =>
+      Pfmadd (freg_of r) (freg_of a1) (freg_of a2) (freg_of a3) :: k
+  | Omulsubf, a1 :: a2 :: a3 :: nil =>
+      Pfmsub (freg_of r) (freg_of a1) (freg_of a2) (freg_of a3) :: k
+  | Osingleoffloat, a1 :: nil =>
+      Pfrsp (freg_of r) (freg_of a1) :: k
+  | Ointoffloat, a1 :: nil =>
+      Pfcti (ireg_of r) (freg_of a1) :: k
+  | Ointuoffloat, a1 :: nil =>
+      Pfctiu (ireg_of r) (freg_of a1) :: k
+  | Ofloatofint, a1 :: nil =>
+      Pictf (freg_of r) (ireg_of a1) :: k
+  | Ofloatofintu, a1 :: nil =>
+      Piuctf (freg_of r) (ireg_of a1) :: k
+  | Ocmp cmp, _ =>
+      let p := crbit_for_cond cmp in
+      transl_cond cmp args
+        (Pmfcrbit (ireg_of r) (fst p) ::
+         if snd p
+         then k
+         else Pxori (ireg_of r) (ireg_of r) (Cint Int.one) :: k)
+  | _, _ =>
+      k (**r never happens for well-typed code *)
+  end.
+
+(** Common code to translate [Mload] and [Mstore] instructions. *)
+
+Definition transl_load_store 
+     (mk1: constant -> ireg -> instruction)
+     (mk2: ireg -> ireg -> instruction)
+     (addr: addressing) (args: list mreg) (k: code) :=
+  match addr, args with
+  | Aindexed ofs, a1 :: nil =>
+      if ireg_eq (ireg_of a1) GPR0 then
+        Pmr GPR12 (ireg_of a1) ::
+        Paddis GPR12 GPR12 (Cint (high_s ofs)) ::
+        mk1 (Cint (low_s ofs)) GPR12 :: k
+      else if Int.eq (high_s ofs) Int.zero then
+        mk1 (Cint ofs) (ireg_of a1) :: k
+      else
+        Paddis GPR12 (ireg_of a1) (Cint (high_s ofs)) ::
+        mk1 (Cint (low_s ofs)) GPR12 :: k
+  | Aindexed2, a1 :: a2 :: nil =>
+      mk2 (ireg_of a1) (ireg_of a2) :: k
+  | Aglobal symb ofs, nil =>
+      Paddis GPR12 GPR0 (Csymbol_high symb ofs) ::
+      mk1 (Csymbol_low symb ofs) GPR12 :: k
+  | Abased symb ofs, a1 :: nil =>
+      if ireg_eq (ireg_of a1) GPR0 then
+        Pmr GPR12 (ireg_of a1) ::
+        Paddis GPR12 GPR12 (Csymbol_high symb ofs) ::
+        mk1 (Csymbol_low symb ofs) GPR12 :: k
+      else
+        Paddis GPR12 (ireg_of a1) (Csymbol_high symb ofs) ::
+        mk1 (Csymbol_low symb ofs) GPR12 :: k
+  | Ainstack ofs, nil =>
+      if Int.eq (high_s ofs) Int.zero then
+        mk1 (Cint ofs) GPR1 :: k
+      else
+        Paddis GPR12 GPR1 (Cint (high_s ofs)) ::
+        mk1 (Cint (low_s ofs)) GPR12 :: k
+  | _, _ =>
+      (* should not happen *) k
+  end.
+
+(** Translation of a Mach instruction. *)
+
+Definition transl_instr (f: Mach.function) (i: Mach.instruction) (k: code) :=
+  match i with
+  | Mgetstack ofs ty dst =>
+      loadind GPR1 ofs ty dst k
+  | Msetstack src ofs ty =>
+      storeind src GPR1 ofs ty k
+  | Mgetparam ofs ty dst =>
+      Plwz GPR12 (Cint f.(fn_link_ofs)) GPR1 :: loadind GPR12 ofs ty dst k
+  | Mop op args res =>
+      transl_op op args res k
+  | Mload chunk addr args dst =>
+      match chunk with
+      | Mint8signed =>
+          transl_load_store
+            (Plbz (ireg_of dst)) (Plbzx (ireg_of dst)) addr args
+            (Pextsb (ireg_of dst) (ireg_of dst) :: k)
+      | Mint8unsigned =>
+          transl_load_store
+            (Plbz (ireg_of dst)) (Plbzx (ireg_of dst)) addr args k
+      | Mint16signed =>
+          transl_load_store
+            (Plha (ireg_of dst)) (Plhax (ireg_of dst)) addr args k
+      | Mint16unsigned =>
+          transl_load_store
+            (Plhz (ireg_of dst)) (Plhzx (ireg_of dst)) addr args k
+      | Mint32 =>
+          transl_load_store
+            (Plwz (ireg_of dst)) (Plwzx (ireg_of dst)) addr args k
+      | Mfloat32 =>
+          transl_load_store
+            (Plfs (freg_of dst)) (Plfsx (freg_of dst)) addr args k
+      | Mfloat64 =>
+          transl_load_store
+            (Plfd (freg_of dst)) (Plfdx (freg_of dst)) addr args k
+      end
+  | Mstore chunk addr args src =>
+      match chunk with
+      | Mint8signed =>
+          transl_load_store
+            (Pstb (ireg_of src)) (Pstbx (ireg_of src)) addr args k
+      | Mint8unsigned =>
+          transl_load_store
+            (Pstb (ireg_of src)) (Pstbx (ireg_of src)) addr args k
+      | Mint16signed =>
+          transl_load_store
+            (Psth (ireg_of src)) (Psthx (ireg_of src)) addr args k
+      | Mint16unsigned =>
+          transl_load_store
+            (Psth (ireg_of src)) (Psthx (ireg_of src)) addr args k
+      | Mint32 =>
+          transl_load_store
+            (Pstw (ireg_of src)) (Pstwx (ireg_of src)) addr args k
+      | Mfloat32 =>
+          transl_load_store
+            (Pstfs (freg_of src)) (Pstfsx (freg_of src)) addr args k
+      | Mfloat64 =>
+          transl_load_store
+            (Pstfd (freg_of src)) (Pstfdx (freg_of src)) addr args k
+      end
+  | Mcall sig (inl r) =>
+      Pmtctr (ireg_of r) :: Pbctrl :: k
+  | Mcall sig (inr symb) =>
+      Pbl symb :: k
+  | Mtailcall sig (inl r) =>
+      Pmtctr (ireg_of r) :: 
+      Plwz GPR12 (Cint f.(fn_retaddr_ofs)) GPR1 ::
+      Pmtlr GPR12 ::
+      Pfreeframe f.(fn_link_ofs) :: 
+      Pbctr :: k
+  | Mtailcall sig (inr symb) =>
+      Plwz GPR12 (Cint f.(fn_retaddr_ofs)) GPR1 ::
+      Pmtlr GPR12 ::
+      Pfreeframe f.(fn_link_ofs) :: 
+      Pbs symb :: k
+  | Malloc =>
+      Pallocblock :: k
+  | Mlabel lbl =>
+      Plabel lbl :: k
+  | Mgoto lbl =>
+      Pb lbl :: k
+  | Mcond cond args lbl =>
+      let p := crbit_for_cond cond in
+      transl_cond cond args
+        (if (snd p) then Pbt (fst p) lbl :: k else Pbf (fst p) lbl :: k)
+  | Mreturn =>
+      Plwz GPR12 (Cint f.(fn_retaddr_ofs)) GPR1 ::
+      Pmtlr GPR12 ::
+      Pfreeframe f.(fn_link_ofs) ::
+      Pblr :: k
+  end.
+
+Definition transl_code (f: Mach.function) (il: list Mach.instruction) :=
+  List.fold_right (transl_instr f) nil il.
+
+(** 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) :=
+  Pallocframe (- f.(fn_framesize)) f.(fn_stacksize) f.(fn_link_ofs) ::
+  Pmflr GPR12 ::
+  Pstw GPR12 (Cint f.(fn_retaddr_ofs)) GPR1 ::
+  transl_code f f.(fn_code).
+
+Fixpoint code_size (c: code) : Z :=
+  match c with
+  | nil => 0
+  | instr :: c' => code_size c' + 1
+  end.
+
+Open Local Scope string_scope.
+
+Definition transf_function (f: Mach.function) : res Asm.code :=
+  let c := transl_function f in
+  if zlt Int.max_unsigned (code_size c)
+  then Errors.Error (msg "code size exceeded")
+  else Errors.OK c.
+
+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.
+
diff --git a/powerpc/Asmgenproof.v b/powerpc/Asmgenproof.v
new file mode 100644
index 00000000..980925bd
--- /dev/null
+++ b/powerpc/Asmgenproof.v
@@ -0,0 +1,1394 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              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 PPC generation: main proof. *)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import Errors.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Mem.
+Require Import Events.
+Require Import Globalenvs.
+Require Import Smallstep.
+Require Import Op.
+Require Import Locations.
+Require Import Mach.
+Require Import Machconcr.
+Require Import Machtyping.
+Require Import Asm.
+Require Import Asmgen.
+Require Import Asmgenretaddr.
+Require Import Asmgenproof1.
+
+Section PRESERVATION.
+
+Variable prog: Mach.program.
+Variable tprog: Asm.program.
+Hypothesis TRANSF: transf_program prog = Errors.OK tprog.
+
+Let ge := Genv.globalenv prog.
+Let tge := Genv.globalenv tprog.
+
+Lemma symbols_preserved:
+  forall id, Genv.find_symbol tge id = Genv.find_symbol ge id.
+Proof.
+  intros. unfold ge, tge. 
+  apply Genv.find_symbol_transf_partial with transf_fundef.
+  exact TRANSF. 
+Qed.
+
+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 = Errors.OK tf.
+Proof
+  (Genv.find_funct_ptr_transf_partial transf_fundef TRANSF).
+
+Lemma functions_transl:
+  forall f b,
+  Genv.find_funct_ptr ge b = Some (Internal f) ->
+  Genv.find_funct_ptr tge b = Some (Internal (transl_function f)).
+Proof.
+  intros. 
+  destruct (functions_translated _ _ H) as [tf [A B]].
+  rewrite A. generalize B. unfold transf_fundef, transf_partial_fundef, transf_function.
+  case (zlt Int.max_unsigned (code_size (transl_function f))); simpl; intro.
+  congruence. intro. inv B0. auto.
+Qed.
+
+Lemma functions_transl_no_overflow:
+  forall b f,
+  Genv.find_funct_ptr ge b = Some (Internal f) ->
+  code_size (transl_function f) <= Int.max_unsigned.
+Proof.
+  intros. 
+  destruct (functions_translated _ _ H) as [tf [A B]].
+  generalize B. unfold transf_fundef, transf_partial_fundef, transf_function.
+  case (zlt Int.max_unsigned (code_size (transl_function f))); simpl; intro.
+  congruence. intro; omega.
+Qed.
+
+(** * Properties of control flow *)
+
+Lemma find_instr_in:
+  forall c pos i,
+  find_instr pos c = Some i -> In i c.
+Proof.
+  induction c; simpl. intros; discriminate.
+  intros until i. case (zeq pos 0); intros.
+  left; congruence. right; eauto.
+Qed.
+
+Lemma find_instr_tail:
+  forall c1 i c2 pos,
+  code_tail pos c1 (i :: c2) ->
+  find_instr pos c1 = Some i.
+Proof.
+  induction c1; simpl; intros.
+  inv H.
+  destruct (zeq pos 0). subst pos.
+  inv H. auto. generalize (code_tail_pos _ _ _ H4). intro. omegaContradiction.
+  inv H. congruence. replace (pos0 + 1 - 1) with pos0 by omega.
+  eauto.
+Qed.
+
+Remark code_size_pos:
+  forall fn, code_size fn >= 0.
+Proof.
+  induction fn; simpl; omega.
+Qed.
+
+Remark code_tail_bounds:
+  forall fn ofs i c,
+  code_tail ofs fn (i :: c) -> 0 <= ofs < code_size fn.
+Proof.
+  assert (forall ofs fn c, code_tail ofs fn c ->
+          forall i c', c = i :: c' -> 0 <= ofs < code_size fn).
+  induction 1; intros; simpl. 
+  rewrite H. simpl. generalize (code_size_pos c'). omega.
+  generalize (IHcode_tail _ _ H0). omega.
+  eauto.
+Qed.
+
+Lemma code_tail_next:
+  forall fn ofs i c,
+  code_tail ofs fn (i :: c) ->
+  code_tail (ofs + 1) fn c.
+Proof.
+  assert (forall ofs fn c, code_tail ofs fn c ->
+          forall i c', c = i :: c' -> code_tail (ofs + 1) fn c').
+  induction 1; intros.
+  subst c. constructor. constructor.
+  constructor. eauto.
+  eauto.
+Qed.
+
+Lemma code_tail_next_int:
+  forall fn ofs i c,
+  code_size fn <= Int.max_unsigned ->
+  code_tail (Int.unsigned ofs) fn (i :: c) ->
+  code_tail (Int.unsigned (Int.add ofs Int.one)) fn c.
+Proof.
+  intros. rewrite Int.add_unsigned.
+  change (Int.unsigned Int.one) with 1.
+  rewrite Int.unsigned_repr. apply code_tail_next with i; auto.
+  generalize (code_tail_bounds _ _ _ _ H0). omega. 
+Qed.
+
+(** [transl_code_at_pc pc fn c] holds if the code pointer [pc] points
+  within the PPC code generated by translating Mach function [fn],
+  and [c] is the tail of the generated code at the position corresponding
+  to the code pointer [pc]. *)
+
+Inductive transl_code_at_pc: val -> block -> Mach.function -> Mach.code -> Prop :=
+  transl_code_at_pc_intro:
+    forall b ofs f c,
+    Genv.find_funct_ptr ge b = Some (Internal f) ->
+    code_tail (Int.unsigned ofs) (transl_function f) (transl_code f c) ->
+    transl_code_at_pc (Vptr b ofs) b f c.
+
+(** The following lemmas show that straight-line executions
+  (predicate [exec_straight]) correspond to correct PPC executions
+  (predicate [exec_steps]) under adequate [transl_code_at_pc] hypotheses. *)
+
+Lemma exec_straight_steps_1:
+  forall fn c rs m c' rs' m',
+  exec_straight tge fn c rs m c' rs' m' ->
+  code_size fn <= Int.max_unsigned ->
+  forall b ofs,
+  rs#PC = Vptr b ofs ->
+  Genv.find_funct_ptr tge b = Some (Internal fn) ->
+  code_tail (Int.unsigned ofs) fn c ->
+  plus step tge (State rs m) E0 (State rs' m').
+Proof.
+  induction 1; intros.
+  apply plus_one.
+  econstructor; eauto. 
+  eapply find_instr_tail. eauto.
+  eapply plus_left'.
+  econstructor; eauto. 
+  eapply find_instr_tail. eauto.
+  apply IHexec_straight with b (Int.add ofs Int.one). 
+  auto. rewrite H0. rewrite H3. reflexivity.
+  auto. 
+  apply code_tail_next_int with i; auto.
+  traceEq.
+Qed.
+    
+Lemma exec_straight_steps_2:
+  forall fn c rs m c' rs' m',
+  exec_straight tge fn c rs m c' rs' m' ->
+  code_size fn <= Int.max_unsigned ->
+  forall b ofs,
+  rs#PC = Vptr b ofs ->
+  Genv.find_funct_ptr tge b = Some (Internal fn) ->
+  code_tail (Int.unsigned ofs) fn c ->
+  exists ofs',
+     rs'#PC = Vptr b ofs'
+  /\ code_tail (Int.unsigned ofs') fn c'.
+Proof.
+  induction 1; intros.
+  exists (Int.add ofs Int.one). split.
+  rewrite H0. rewrite H2. auto.
+  apply code_tail_next_int with i1; auto.
+  apply IHexec_straight with (Int.add ofs Int.one).
+  auto. rewrite H0. rewrite H3. reflexivity. auto. 
+  apply code_tail_next_int with i; auto.
+Qed.
+
+Lemma exec_straight_exec:
+  forall fb f c c' rs m rs' m',
+  transl_code_at_pc (rs PC) fb f c ->
+  exec_straight tge (transl_function f)
+                (transl_code f c) rs m c' rs' m' ->
+  plus step tge (State rs m) E0 (State rs' m').
+Proof.
+  intros. inversion H. subst.
+  eapply exec_straight_steps_1; eauto.
+  eapply functions_transl_no_overflow; eauto. 
+  eapply functions_transl; eauto.
+Qed.
+
+Lemma exec_straight_at:
+  forall fb f c c' rs m rs' m',
+  transl_code_at_pc (rs PC) fb f c ->
+  exec_straight tge (transl_function f)
+                (transl_code f c) rs m (transl_code f c') rs' m' ->
+  transl_code_at_pc (rs' PC) fb f c'.
+Proof.
+  intros. inversion H. subst. 
+  generalize (functions_transl_no_overflow _ _ H2). intro.
+  generalize (functions_transl _ _ H2). intro.
+  generalize (exec_straight_steps_2 _ _ _ _ _ _ _
+                H0 H4 _ _ (sym_equal H1) H5 H3).
+  intros [ofs' [PC' CT']].
+  rewrite PC'. constructor; auto.
+Qed.
+
+(** Correctness of the return addresses predicted by
+    [PPCgen.return_address_offset]. *)
+
+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 b ofs fb f c ofs',
+  transl_code_at_pc (Vptr b ofs) fb f c ->
+  return_address_offset f c ofs' ->
+  ofs' = ofs.
+Proof.
+  intros. inv H0. inv H. 
+  generalize (code_tail_unique _ _ _ _ H1 H7). intro. rewrite H. 
+  apply Int.repr_unsigned.
+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: code) {struct c} : option code :=
+  match c with
+  | nil => None
+  | instr :: c' =>
+      if is_label lbl instr then Some c' else find_label lbl c'
+  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 + code_size c.
+Proof.
+  induction c. 
+  simpl; intros. discriminate.
+  simpl; intros until c'.
+  case (is_label lbl a).
+  intro EQ; injection EQ; intro; subst c'.
+  exists (pos + 1). split. auto. split.
+  replace (pos + 1 - pos) with (0 + 1) by omega. constructor. constructor. 
+  generalize (code_size_pos c). omega. 
+  intros. generalize (IHc (pos + 1) c' H). intros [pos' [A [B C]]].
+  exists pos'. split. auto. split.
+  replace (pos' - pos) with ((pos' - (pos + 1)) + 1) by omega.
+  constructor. auto. 
+  omega.
+Qed.
+
+(** The following lemmas show that the translation from Mach to PPC
+  preserves labels, in the sense that the following diagram commutes:
+<<
+                          translation
+        Mach code ------------------------ PPC instr sequence
+            |                                          |
+            | Mach.find_label lbl       find_label lbl |
+            |                                          |
+            v                                          v
+        Mach code tail ------------------- PPC instr seq tail
+                          translation
+>>
+  The proof demands many boring lemmas showing that PPC constructor
+  functions do not introduce new labels.
+*)
+
+Section TRANSL_LABEL.
+
+Variable lbl: label.
+
+Remark loadimm_label:
+  forall r n k, find_label lbl (loadimm r n k) = find_label lbl k.
+Proof.
+  intros. unfold loadimm. 
+  case (Int.eq (high_s n) Int.zero). reflexivity. 
+  case (Int.eq (low_s n) Int.zero). reflexivity.
+  reflexivity.
+Qed.
+Hint Rewrite loadimm_label: labels.
+
+Remark addimm_1_label:
+  forall r1 r2 n k, find_label lbl (addimm_1 r1 r2 n k) = find_label lbl k.
+Proof.
+  intros; unfold addimm_1. 
+  case (Int.eq (high_s n) Int.zero). reflexivity.
+  case (Int.eq (low_s n) Int.zero). reflexivity. reflexivity.
+Qed.
+Remark addimm_2_label:
+  forall r1 r2 n k, find_label lbl (addimm_2 r1 r2 n k) = find_label lbl k.
+Proof.
+  intros; unfold addimm_2. autorewrite with labels. reflexivity.
+Qed.
+Remark addimm_label:
+  forall r1 r2 n k, find_label lbl (addimm r1 r2 n k) = find_label lbl k.
+Proof.
+  intros; unfold addimm. 
+  case (ireg_eq r1 GPR0); intro. apply addimm_2_label.
+  case (ireg_eq r2 GPR0); intro. apply addimm_2_label.
+  apply addimm_1_label.
+Qed.
+Hint Rewrite addimm_label: labels.
+
+Remark andimm_label:
+  forall r1 r2 n k, find_label lbl (andimm r1 r2 n k) = find_label lbl k.
+Proof.
+  intros; unfold andimm. 
+  case (Int.eq (high_u n) Int.zero). reflexivity.
+  case (Int.eq (low_u n) Int.zero). reflexivity.
+  autorewrite with labels. reflexivity.
+Qed.
+Hint Rewrite andimm_label: labels.
+
+Remark orimm_label:
+  forall r1 r2 n k, find_label lbl (orimm r1 r2 n k) = find_label lbl k.
+Proof.
+  intros; unfold orimm. 
+  case (Int.eq (high_u n) Int.zero). reflexivity.
+  case (Int.eq (low_u n) Int.zero). reflexivity. reflexivity.
+Qed.
+Hint Rewrite orimm_label: labels.
+
+Remark xorimm_label:
+  forall r1 r2 n k, find_label lbl (xorimm r1 r2 n k) = find_label lbl k.
+Proof.
+  intros; unfold xorimm. 
+  case (Int.eq (high_u n) Int.zero). reflexivity.
+  case (Int.eq (low_u n) Int.zero). reflexivity. reflexivity.
+Qed.
+Hint Rewrite xorimm_label: labels.
+
+Remark loadind_aux_label:
+  forall base ofs ty dst k, find_label lbl (loadind_aux base ofs ty dst :: k) = find_label lbl k.
+Proof.
+  intros; unfold loadind_aux.
+  case ty; reflexivity.
+Qed.
+Remark loadind_label:
+  forall base ofs ty dst k, find_label lbl (loadind base ofs ty dst k) = find_label lbl k.
+Proof.
+  intros; unfold loadind. 
+  case (Int.eq (high_s ofs) Int.zero). apply loadind_aux_label.
+  transitivity (find_label lbl (loadind_aux GPR12 (low_s ofs) ty dst :: k)).
+  reflexivity. apply loadind_aux_label.
+Qed.
+Hint Rewrite loadind_label: labels.
+Remark storeind_aux_label:
+  forall base ofs ty dst k, find_label lbl (storeind_aux base ofs ty dst :: k) = find_label lbl k.
+Proof.
+  intros; unfold storeind_aux.
+  case dst; reflexivity.
+Qed.
+Remark storeind_label:
+  forall base ofs ty src k, find_label lbl (storeind base src ofs ty k) = find_label lbl k.
+Proof.
+  intros; unfold storeind. 
+  case (Int.eq (high_s ofs) Int.zero). apply storeind_aux_label.
+  transitivity (find_label lbl (storeind_aux base GPR12 (low_s ofs) ty :: k)).
+  reflexivity. apply storeind_aux_label.
+Qed.
+Hint Rewrite storeind_label: labels.
+Remark floatcomp_label:
+  forall cmp r1 r2 k, find_label lbl (floatcomp cmp r1 r2 k) = find_label lbl k.
+Proof.
+  intros; unfold floatcomp. destruct cmp; reflexivity.
+Qed.
+
+Remark transl_cond_label:
+  forall cond args k, find_label lbl (transl_cond cond args k) = find_label lbl k.
+Proof.
+  intros; unfold transl_cond.
+  destruct cond; (destruct args; 
+  [try reflexivity | destruct args;
+  [try reflexivity | destruct args; try reflexivity]]).
+  case (Int.eq (high_s i) Int.zero). reflexivity. 
+  autorewrite with labels; reflexivity.
+  case (Int.eq (high_u i) Int.zero). reflexivity. 
+  autorewrite with labels; reflexivity.
+  apply floatcomp_label. apply floatcomp_label.
+  apply andimm_label. apply andimm_label.
+Qed.
+Hint Rewrite transl_cond_label: labels.
+Remark transl_op_label:
+  forall op args r k, find_label lbl (transl_op op args r k) = find_label lbl k.
+Proof.
+  intros; unfold transl_op;
+  destruct op; destruct args; try (destruct args); try (destruct args); try (destruct args);
+  try reflexivity; autorewrite with labels; try reflexivity.
+  case (mreg_type m); reflexivity.
+  case (Int.eq (high_s i) Int.zero); autorewrite with labels; reflexivity.
+  case (Int.eq (high_s i) Int.zero); autorewrite with labels; reflexivity.
+  case (snd (crbit_for_cond c)); reflexivity.
+  case (snd (crbit_for_cond c)); reflexivity.
+  case (snd (crbit_for_cond c)); reflexivity.
+  case (snd (crbit_for_cond c)); reflexivity.
+  case (snd (crbit_for_cond c)); reflexivity.
+Qed.
+Hint Rewrite transl_op_label: labels.
+
+Remark transl_load_store_label:
+  forall (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction)
+         addr args k,
+  (forall c r, is_label lbl (mk1 c r) = false) ->
+  (forall r1 r2, is_label lbl (mk2 r1 r2) = false) ->
+  find_label lbl (transl_load_store mk1 mk2 addr args k) = find_label lbl k.
+Proof.
+  intros; unfold transl_load_store.
+  destruct addr; destruct args; try (destruct args); try (destruct args);
+  try reflexivity.
+  case (ireg_eq (ireg_of m) GPR0); intro.
+  simpl. rewrite H. auto. 
+  case (Int.eq (high_s i) Int.zero). simpl; rewrite H; auto.
+  simpl; rewrite H; auto.
+  simpl; rewrite H0; auto.
+  simpl; rewrite H; auto.
+  case (ireg_eq (ireg_of m) GPR0); intro; simpl; rewrite H; auto. 
+  case (Int.eq (high_s i) Int.zero); simpl; rewrite H; auto.
+Qed.
+Hint Rewrite transl_load_store_label: labels.
+
+Lemma transl_instr_label:
+  forall f i k,
+  find_label lbl (transl_instr f i k) = 
+    if Mach.is_label lbl i then Some k else find_label lbl k.
+Proof.
+  intros. generalize (Mach.is_label_correct lbl i). 
+  case (Mach.is_label lbl i); intro.
+  subst i. simpl. rewrite peq_true. auto.
+  destruct i; simpl; autorewrite with labels; try reflexivity.
+  destruct m; rewrite transl_load_store_label; intros; reflexivity. 
+  destruct m; rewrite transl_load_store_label; intros; reflexivity. 
+  destruct s0; reflexivity.
+  destruct s0; reflexivity.
+  rewrite peq_false. auto. congruence.
+  case (snd (crbit_for_cond c)); reflexivity.
+Qed.
+
+Lemma transl_code_label:
+  forall f c,
+  find_label lbl (transl_code f c) = 
+    option_map (transl_code f) (Mach.find_label lbl c).
+Proof.
+  induction c; simpl; intros.
+  auto. rewrite transl_instr_label.
+  case (Mach.is_label lbl a). reflexivity.
+  auto.
+Qed.
+
+Lemma transl_find_label:
+  forall f,
+  find_label lbl (transl_function f) = 
+    option_map (transl_code f) (Mach.find_label lbl f.(fn_code)).
+Proof.
+  intros. unfold transl_function. simpl. apply transl_code_label.
+Qed.
+
+End TRANSL_LABEL.
+
+(** A valid branch in a piece of Mach code translates to a valid ``go to''
+  transition in the generated PPC code. *)
+
+Lemma find_label_goto_label:
+  forall f lbl rs m c' b ofs,
+  Genv.find_funct_ptr ge b = Some (Internal f) ->
+  rs PC = Vptr b ofs ->
+  Mach.find_label lbl f.(fn_code) = Some c' ->
+  exists rs',
+    goto_label (transl_function f) lbl rs m = OK rs' m  
+  /\ transl_code_at_pc (rs' PC) b f c'
+  /\ forall r, r <> PC -> rs'#r = rs#r.
+Proof.
+  intros. 
+  generalize (transl_find_label lbl f).
+  rewrite H1; simpl. intro.
+  generalize (label_pos_code_tail lbl (transl_function f) 0 
+                 (transl_code f c') H2).
+  intros [pos' [A [B C]]].
+  exists (rs#PC <- (Vptr b (Int.repr pos'))).
+  split. unfold goto_label. rewrite A. rewrite H0. auto.
+  split. rewrite Pregmap.gss. constructor; auto. 
+  rewrite Int.unsigned_repr. replace (pos' - 0) with pos' in B.
+  auto. omega. 
+  generalize (functions_transl_no_overflow _ _ H). 
+  omega.
+  intros. apply Pregmap.gso; auto.
+Qed.
+
+(** * Memory properties *)
+
+(** The PowerPC has no instruction for ``load 8-bit signed integer''.
+  We show that it can be synthesized as a ``load 8-bit unsigned integer''
+  followed by a sign extension. *)
+
+Remark valid_access_equiv:
+  forall chunk1 chunk2 m b ofs,
+  size_chunk chunk1 = size_chunk chunk2 ->
+  valid_access m chunk1 b ofs ->
+  valid_access m chunk2 b ofs.
+Proof.
+  intros. inv H0. rewrite H in H3. constructor; auto.
+Qed.
+
+Remark in_bounds_equiv:
+  forall chunk1 chunk2 m b ofs (A: Set) (a1 a2: A),
+  size_chunk chunk1 = size_chunk chunk2 ->
+  (if in_bounds m chunk1 b ofs then a1 else a2) =
+  (if in_bounds m chunk2 b ofs then a1 else a2).
+Proof.
+  intros. destruct (in_bounds m chunk1 b ofs).
+  rewrite in_bounds_true. auto. eapply valid_access_equiv; eauto.
+  destruct (in_bounds m chunk2 b ofs); auto.
+  elim n. eapply valid_access_equiv with (chunk1 := chunk2); eauto.
+Qed.
+
+Lemma loadv_8_signed_unsigned:
+  forall m a,
+  Mem.loadv Mint8signed m a = 
+    option_map (Val.sign_ext 8) (Mem.loadv Mint8unsigned m a).
+Proof.
+  intros. unfold Mem.loadv. destruct a; try reflexivity.
+  unfold load. rewrite (in_bounds_equiv Mint8signed Mint8unsigned).
+  destruct (in_bounds m Mint8unsigned b (Int.signed i)); auto.
+  simpl.
+  destruct (getN 0 (Int.signed i) (contents (blocks m b))); auto.
+  simpl. rewrite Int.sign_ext_zero_ext. auto. compute; auto. 
+  auto.
+Qed.
+
+(** Similarly, we show that signed 8- and 16-bit stores can be performed
+  like unsigned stores. *)
+
+Lemma storev_8_signed_unsigned:
+  forall m a v,
+  Mem.storev Mint8signed m a v = Mem.storev Mint8unsigned m a v.
+Proof.
+  intros. unfold storev. destruct a; auto.
+  unfold store. rewrite (in_bounds_equiv Mint8signed Mint8unsigned).
+  auto. auto.
+Qed.
+
+Lemma storev_16_signed_unsigned:
+  forall m a v,
+  Mem.storev Mint16signed m a v = Mem.storev Mint16unsigned m a v.
+Proof.
+  intros. unfold storev. destruct a; auto.
+  unfold store. rewrite (in_bounds_equiv Mint16signed Mint16unsigned).
+  auto. auto.
+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 PPC code pointed by the PC register is the translation of
+  the current Mach code sequence.
+- Mach register values and PPC register values agree.
+*)
+
+Inductive match_stack: list Machconcr.stackframe -> Prop :=
+  | match_stack_nil:
+      match_stack nil
+  | match_stack_cons: forall fb sp ra c s f,
+      Genv.find_funct_ptr ge fb = Some (Internal f) ->
+      wt_function f ->
+      incl c f.(fn_code) ->
+      transl_code_at_pc ra fb f c ->
+      match_stack s ->
+      match_stack (Stackframe fb sp ra c :: s).
+
+Inductive match_states: Machconcr.state -> Asm.state -> Prop :=
+  | match_states_intro:
+      forall s fb sp c ms m rs f
+        (STACKS: match_stack s)
+        (FIND: Genv.find_funct_ptr ge fb = Some (Internal f))
+        (WTF: wt_function f)
+        (INCL: incl c f.(fn_code))
+        (AT: transl_code_at_pc (rs PC) fb f c)
+        (AG: agree ms sp rs),
+      match_states (Machconcr.State s fb sp c ms m)
+                   (Asm.State rs m)
+  | match_states_call:
+      forall s fb ms m rs
+        (STACKS: match_stack s)
+        (AG: agree ms (parent_sp s) rs)
+        (ATPC: rs PC = Vptr fb Int.zero)
+        (ATLR: rs LR = parent_ra s),
+      match_states (Machconcr.Callstate s fb ms m)
+                   (Asm.State rs m)
+  | match_states_return:
+      forall s ms m rs
+        (STACKS: match_stack s)
+        (AG: agree ms (parent_sp s) rs)
+        (ATPC: rs PC = parent_ra s),
+      match_states (Machconcr.Returnstate s ms m)
+                   (Asm.State rs m).
+
+Lemma exec_straight_steps:
+  forall s fb sp m1 f c1 rs1 c2 m2 ms2,
+  match_stack s ->
+  Genv.find_funct_ptr ge fb = Some (Internal f) ->
+  wt_function f ->
+  incl c2 f.(fn_code) ->
+  transl_code_at_pc (rs1 PC) fb f c1 ->
+  (exists rs2,
+     exec_straight tge (transl_function f) (transl_code f c1) rs1 m1 (transl_code f c2) rs2 m2
+     /\ agree ms2 sp rs2) ->
+  exists st',
+  plus step tge (State rs1 m1) E0 st' /\
+  match_states (Machconcr.State s fb sp c2 ms2 m2) st'.
+Proof.
+  intros. destruct H4 as [rs2 [A B]].
+  exists (State rs2 m2); split.
+  eapply exec_straight_exec; eauto.
+  econstructor; eauto. eapply exec_straight_at; eauto.
+Qed.
+
+(** We need to show that, in the simulation diagram, we cannot
+  take infinitely many Mach transitions that correspond to zero
+  transitions on the PPC side.  Actually, all Mach transitions
+  correspond to at least one PPC transition, except the
+  transition from [Machconcr.Returnstate] to [Machconcr.State].
+  So, the following integer measure will suffice to rule out
+  the unwanted behaviour. *)
+
+Definition measure (s: Machconcr.state) : nat :=
+  match s with
+  | Machconcr.State _ _ _ _ _ _ => 0%nat
+  | Machconcr.Callstate _ _ _ _ => 0%nat
+  | Machconcr.Returnstate _ _ _ => 1%nat
+  end.
+
+(** We show the simulation diagram by case analysis on the Mach transition
+  on the left.  Since the proof is large, we break it into one lemma
+  per transition. *)
+
+Definition exec_instr_prop (s1: Machconcr.state) (t: trace) (s2: Machconcr.state) : Prop :=
+  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.
+
+
+Lemma exec_Mlabel_prop:
+  forall (s : list stackframe) (fb : block) (sp : val)
+         (lbl : Mach.label) (c : list Mach.instruction) (ms : Mach.regset)
+         (m : mem),
+  exec_instr_prop (Machconcr.State s fb sp (Mlabel lbl :: c) ms m) E0
+                  (Machconcr.State s fb sp c ms m).
+Proof.
+  intros; red; intros; inv MS.
+  left; eapply exec_straight_steps; eauto with coqlib.
+  exists (nextinstr rs); split.
+  simpl. apply exec_straight_one. reflexivity. reflexivity.
+  apply agree_nextinstr; auto.
+Qed.
+
+Lemma exec_Mgetstack_prop:
+  forall (s : list stackframe) (fb : block) (sp : val) (ofs : int)
+         (ty : typ) (dst : mreg) (c : list Mach.instruction)
+         (ms : Mach.regset) (m : mem) (v : val),
+  load_stack m sp ty ofs = Some v ->
+  exec_instr_prop (Machconcr.State s fb sp (Mgetstack ofs ty dst :: c) ms m) E0
+                  (Machconcr.State s fb sp c (Regmap.set dst v ms) m).
+Proof.
+  intros; red; intros; inv MS.
+  unfold load_stack in H. 
+  generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
+  intro WTI. inversion WTI.
+  rewrite (sp_val _ _ _ AG) in H.
+  assert (NOTE: GPR1 <> GPR0). congruence.
+  generalize (loadind_correct tge (transl_function f) GPR1 ofs ty
+                dst (transl_code f c) rs m v H H1 NOTE).
+  intros [rs2 [EX [RES OTH]]].
+  left; eapply exec_straight_steps; eauto with coqlib.
+  simpl. exists rs2; split. auto. 
+  apply agree_exten_2 with (rs#(preg_of dst) <- v).
+  auto with ppcgen. 
+  intros. case (preg_eq r0 (preg_of dst)); intro.
+  subst r0. rewrite Pregmap.gss. auto. 
+  rewrite Pregmap.gso; auto.
+Qed.
+
+Lemma exec_Msetstack_prop:
+  forall (s : list stackframe) (fb : block) (sp : val) (src : mreg)
+         (ofs : int) (ty : typ) (c : list Mach.instruction)
+         (ms : mreg -> val) (m m' : mem),
+  store_stack m sp ty ofs (ms src) = Some m' ->
+  exec_instr_prop (Machconcr.State s fb sp (Msetstack src ofs ty :: c) ms m) E0
+                  (Machconcr.State s fb sp c ms m').
+Proof.
+  intros; red; intros; inv MS.
+  unfold store_stack in H. 
+  generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
+  intro WTI. inversion WTI.
+  rewrite (sp_val _ _ _ AG) in H.
+  rewrite (preg_val ms sp rs) in H; auto.
+  assert (NOTE: GPR1 <> GPR0). congruence.
+  generalize (storeind_correct tge (transl_function f) GPR1 ofs ty
+                src (transl_code f c) rs m m' H H1 NOTE).
+  intros [rs2 [EX OTH]].
+  left; eapply exec_straight_steps; eauto with coqlib.
+  exists rs2; split; auto.
+  apply agree_exten_2 with rs; auto.
+Qed.
+
+Lemma exec_Mgetparam_prop:
+  forall (s : list stackframe) (fb : block) (f: Mach.function) (sp parent : val)
+         (ofs : int) (ty : typ) (dst : mreg) (c : list Mach.instruction)
+         (ms : Mach.regset) (m : mem) (v : val),
+  Genv.find_funct_ptr ge fb = Some (Internal f) ->
+  load_stack m sp Tint f.(fn_link_ofs) = Some parent ->
+  load_stack m parent ty ofs = Some v ->
+  exec_instr_prop (Machconcr.State s fb sp (Mgetparam ofs ty dst :: c) ms m) E0
+                  (Machconcr.State s fb sp c (Regmap.set dst v ms) m).
+Proof.
+  intros; red; intros; inv MS.
+  assert (f0 = f) by congruence. subst f0.
+  set (rs2 := nextinstr (rs#GPR12 <- parent)).
+  assert (EX1: exec_straight tge (transl_function f)
+                 (transl_code f (Mgetparam ofs ty dst :: c)) rs m
+                 (loadind GPR12 ofs ty dst (transl_code f c)) rs2 m).
+  simpl. apply exec_straight_one.
+  simpl. unfold load1. rewrite gpr_or_zero_not_zero; auto with ppcgen.
+  unfold const_low. rewrite <- (sp_val ms sp rs); auto.
+  unfold load_stack in H0. simpl chunk_of_type in H0. 
+  rewrite H0. reflexivity. reflexivity.
+  generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
+  intro WTI. inversion WTI.
+  unfold load_stack in H1. change parent with rs2#GPR12 in H1.
+  assert (NOTE: GPR12 <> GPR0). congruence.
+  generalize (loadind_correct tge (transl_function f) GPR12 ofs ty
+                dst (transl_code f c) rs2 m v H1 H3 NOTE).
+  intros [rs3 [EX2 [RES OTH]]].
+  left; eapply exec_straight_steps; eauto with coqlib.
+  exists rs3; split; simpl.
+  eapply exec_straight_trans; eauto.
+  apply agree_exten_2 with (rs2#(preg_of dst) <- v).
+  unfold rs2; auto with ppcgen.
+  intros. case (preg_eq r0 (preg_of dst)); intro.
+  subst r0. rewrite Pregmap.gss. auto. 
+  rewrite Pregmap.gso; auto. 
+Qed.
+
+Lemma exec_Mop_prop:
+  forall (s : list stackframe) (fb : block) (sp : val) (op : operation)
+         (args : list mreg) (res : mreg) (c : list Mach.instruction)
+         (ms : mreg -> val) (m : mem) (v : val),
+  eval_operation ge sp op ms ## args m = Some v ->
+  exec_instr_prop (Machconcr.State s fb sp (Mop op args res :: c) ms m) E0
+                  (Machconcr.State s fb sp c (Regmap.set res v ms) m).
+Proof.
+  intros; red; intros; inv MS.
+  generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
+  intro WTI.
+  left; eapply exec_straight_steps; eauto with coqlib.
+  simpl. eapply transl_op_correct; auto.
+  rewrite <- H. apply eval_operation_preserved. exact symbols_preserved.
+Qed.
+
+Lemma exec_Mload_prop:
+  forall (s : list stackframe) (fb : block) (sp : val)
+         (chunk : memory_chunk) (addr : addressing) (args : list mreg)
+         (dst : mreg) (c : list Mach.instruction) (ms : mreg -> val)
+         (m : mem) (a v : val),
+  eval_addressing ge sp addr ms ## args = Some a ->
+  loadv chunk m a = Some v ->
+  exec_instr_prop (Machconcr.State s fb sp (Mload chunk addr args dst :: c) ms m)
+               E0 (Machconcr.State s fb sp c (Regmap.set dst v ms) m).
+Proof.
+  intros; red; intros; inv MS.
+  generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
+  intro WTI; inversion WTI.
+  assert (eval_addressing tge sp addr ms##args = Some a).
+    rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
+  left; eapply exec_straight_steps; eauto with coqlib;
+  destruct chunk; simpl; simpl in H6;
+  (* all cases but Mint8signed *)
+  try (eapply transl_load_correct; eauto;
+       intros; simpl; unfold preg_of; rewrite H6; auto).
+  (* Mint8signed *)
+  generalize (loadv_8_signed_unsigned m a).
+  rewrite H0. 
+  caseEq (loadv Mint8unsigned m a);
+  [idtac | simpl;intros;discriminate].
+  intros v' LOAD' EQ. simpl in EQ. injection EQ. intro EQ1. clear EQ.
+  assert (X1: forall (cst : constant) (r1 : ireg) (rs1 : regset),
+    exec_instr tge (transl_function f) (Plbz (ireg_of dst) cst r1) rs1 m =
+    load1 tge Mint8unsigned (preg_of dst) cst r1 rs1 m).
+    intros. unfold preg_of; rewrite H6. reflexivity. 
+  assert (X2: forall (r1 r2 : ireg) (rs1 : regset),
+    exec_instr tge (transl_function f) (Plbzx (ireg_of dst) r1 r2) rs1 m =
+    load2 Mint8unsigned (preg_of dst) r1 r2 rs1 m).
+    intros. unfold preg_of; rewrite H6. reflexivity. 
+  generalize (transl_load_correct tge (transl_function f)
+                (Plbz (ireg_of dst)) (Plbzx (ireg_of dst))
+                Mint8unsigned addr args 
+                (Pextsb (ireg_of dst) (ireg_of dst) :: transl_code f c) 
+                ms sp rs m dst a v'
+                X1 X2 AG H3 H7 LOAD').
+  intros [rs2 [EX1 AG1]].
+  exists (nextinstr (rs2#(ireg_of dst) <- v)).
+  split. eapply exec_straight_trans. eexact EX1.
+  apply exec_straight_one. simpl. 
+  rewrite <- (ireg_val _ _ _ dst AG1);auto. rewrite Regmap.gss. 
+  rewrite EQ1. reflexivity. reflexivity. 
+  eauto with ppcgen.
+Qed.
+
+Lemma exec_Mstore_prop:
+  forall (s : list stackframe) (fb : block) (sp : val)
+         (chunk : memory_chunk) (addr : addressing) (args : list mreg)
+         (src : mreg) (c : list Mach.instruction) (ms : mreg -> val)
+         (m m' : mem) (a : val),
+  eval_addressing ge sp addr ms ## args = Some a ->
+  storev chunk m a (ms src) = Some m' ->
+  exec_instr_prop (Machconcr.State s fb sp (Mstore chunk addr args src :: c) ms m) E0
+                  (Machconcr.State s fb sp c ms m').
+Proof.
+  intros; red; intros; inv MS.
+  generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
+  intro WTI; inversion WTI.
+  rewrite <- (eval_addressing_preserved symbols_preserved) in H.
+  left; eapply exec_straight_steps; eauto with coqlib. 
+  destruct chunk; simpl; simpl in H6;
+  try (rewrite storev_8_signed_unsigned in H0);
+  try (rewrite storev_16_signed_unsigned in H0);
+  simpl; eapply transl_store_correct; eauto;
+  intros; unfold preg_of; rewrite H6; reflexivity.
+Qed.
+
+Lemma exec_Mcall_prop:
+  forall (s : list stackframe) (fb : block) (sp : val)
+         (sig : signature) (ros : mreg + ident) (c : Mach.code)
+         (ms : Mach.regset) (m : mem) (f : function) (f' : block)
+         (ra : int),
+  find_function_ptr ge ros ms = Some f' ->
+  Genv.find_funct_ptr ge fb = Some (Internal f) ->
+  return_address_offset f c ra ->
+  exec_instr_prop (Machconcr.State s fb sp (Mcall sig ros :: c) ms m) E0
+                  (Callstate (Stackframe fb sp (Vptr fb ra) c :: s) f' ms m).
+Proof.
+  intros; red; intros; inv MS.
+  assert (f0 = f) by congruence. subst f0.
+  generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
+  intro WTI. inversion WTI.
+  inv AT. 
+  assert (NOOV: code_size (transl_function f) <= Int.max_unsigned).
+    eapply functions_transl_no_overflow; eauto.
+  destruct ros; simpl in H; simpl transl_code in H7.
+  (* Indirect call *)
+  generalize (code_tail_next_int _ _ _ _ NOOV H7). intro CT1.
+  generalize (code_tail_next_int _ _ _ _ NOOV CT1). intro CT2.
+  set (rs2 := nextinstr (rs#CTR <- (ms m0))).
+  set (rs3 := rs2 #LR <- (Val.add rs2#PC Vone) #PC <- (ms m0)).
+  assert (ATPC: rs3 PC = Vptr f' Int.zero).
+    change (rs3 PC) with (ms m0). 
+    destruct (ms m0); try discriminate.
+    generalize H; predSpec Int.eq Int.eq_spec i Int.zero; intros; congruence.
+  exploit return_address_offset_correct; eauto. constructor; eauto. 
+  intro RA_EQ.
+  assert (ATLR: rs3 LR = Vptr fb ra).
+    rewrite RA_EQ.
+    change (rs3 LR) with (Val.add (Val.add (rs PC) Vone) Vone).
+    rewrite <- H5. reflexivity. 
+  assert (AG3: agree ms sp rs3). 
+    unfold rs3, rs2; auto 8 with ppcgen.
+  left; exists (State rs3 m); split.
+  apply plus_left with E0 (State rs2 m) E0. 
+    econstructor. eauto. apply functions_transl. eexact H0. 
+    eapply find_instr_tail. eauto.
+    simpl. rewrite <- (ireg_val ms sp rs); auto. 
+  apply star_one. econstructor.
+    change (rs2 PC) with (Val.add (rs PC) Vone). rewrite <- H5.
+    simpl. auto.
+    apply functions_transl. eexact H0.
+    eapply find_instr_tail. eauto.
+    simpl. reflexivity.
+  traceEq.
+  econstructor; eauto.
+  econstructor; eauto with coqlib.
+  rewrite RA_EQ. econstructor; eauto.
+  (* Direct call *)
+  generalize (code_tail_next_int _ _ _ _ NOOV H7). intro CT1.
+  set (rs2 := rs #LR <- (Val.add rs#PC Vone) #PC <- (symbol_offset tge i Int.zero)).
+  assert (ATPC: rs2 PC = Vptr f' Int.zero).
+    change (rs2 PC) with (symbol_offset tge i Int.zero).
+    unfold symbol_offset. rewrite symbols_preserved. rewrite H. auto.
+  exploit return_address_offset_correct; eauto. constructor; eauto. 
+  intro RA_EQ.
+  assert (ATLR: rs2 LR = Vptr fb ra).
+    rewrite RA_EQ.
+    change (rs2 LR) with (Val.add (rs PC) Vone).
+    rewrite <- H5. reflexivity. 
+  assert (AG2: agree ms sp rs2). 
+    unfold rs2; auto 8 with ppcgen.
+  left; exists (State rs2 m); split.
+  apply plus_one. econstructor. 
+    eauto.
+    apply functions_transl. eexact H0. 
+    eapply find_instr_tail. eauto.
+    simpl. reflexivity.
+  econstructor; eauto with coqlib.
+  econstructor; eauto with coqlib.
+  rewrite RA_EQ. econstructor; eauto.
+Qed.
+
+Lemma exec_Mtailcall_prop:
+  forall (s : list stackframe) (fb stk : block) (soff : int)
+         (sig : signature) (ros : mreg + ident) (c : list Mach.instruction)
+         (ms : Mach.regset) (m : mem) (f: Mach.function) (f' : block),
+  find_function_ptr ge ros ms = Some f' ->
+  Genv.find_funct_ptr ge fb = Some (Internal f) ->
+  load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) ->
+  load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) ->
+  exec_instr_prop
+          (Machconcr.State s fb (Vptr stk soff) (Mtailcall sig ros :: c) ms m) E0
+          (Callstate s f' ms (free m stk)).
+Proof.
+  intros; red; intros; inv MS.
+  assert (f0 = f) by congruence. subst f0.
+  generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
+  intro WTI. inversion WTI.
+  inversion AT. subst b f0 c0.
+  assert (NOOV: code_size (transl_function f) <= Int.max_unsigned).
+    eapply functions_transl_no_overflow; eauto.
+  destruct ros; simpl in H; simpl in H9.
+  (* Indirect call *)
+  set (rs2 := nextinstr (rs#CTR <- (ms m0))).
+  set (rs3 := nextinstr (rs2#GPR12 <- (parent_ra s))).
+  set (rs4 := nextinstr (rs3#LR <- (parent_ra s))).
+  set (rs5 := nextinstr (rs4#GPR1 <- (parent_sp s))).
+  set (rs6 := rs5#PC <- (rs5 CTR)).
+  assert (exec_straight tge (transl_function f)
+            (transl_code f (Mtailcall sig (inl ident m0) :: c)) rs m 
+            (Pbctr :: transl_code f c) rs5 (free m stk)).
+  simpl. apply exec_straight_step with rs2 m. 
+  simpl. rewrite <- (ireg_val _ _ _ _ AG H6). reflexivity. reflexivity.
+  apply exec_straight_step with rs3 m.
+  simpl. unfold load1. rewrite gpr_or_zero_not_zero. unfold const_low.
+  change (rs2 GPR1) with (rs GPR1). rewrite <- (sp_val _ _ _ AG). 
+  simpl. unfold load_stack in H2. simpl in H2. rewrite H2.
+  reflexivity. discriminate. reflexivity.
+  apply exec_straight_step with rs4 m.
+  simpl. reflexivity. reflexivity.
+  apply exec_straight_one. 
+  simpl. change (rs4 GPR1) with (rs GPR1). rewrite <- (sp_val _ _ _ AG).
+  unfold load_stack in H1; simpl in H1. 
+  simpl. rewrite H1. reflexivity. reflexivity.
+  left; exists (State rs6 (free m stk)); split.
+  (* execution *)
+  eapply plus_right'. eapply exec_straight_exec; eauto.
+  econstructor.
+  change (rs5 PC) with (Val.add (Val.add (Val.add (Val.add (rs PC) Vone) Vone) Vone) Vone).
+  rewrite <- H7; simpl. eauto.
+  eapply functions_transl; eauto. 
+  eapply find_instr_tail.
+  repeat (eapply code_tail_next_int; auto). eauto. 
+  simpl. reflexivity. traceEq.
+  (* match states *)
+  econstructor; eauto.
+  assert (AG4: agree ms (Vptr stk soff) rs4).
+    unfold rs4, rs3, rs2; auto 10 with ppcgen.
+  assert (AG5: agree ms (parent_sp s) rs5).
+    unfold rs5. apply agree_nextinstr.
+    split. reflexivity. intros. inv AG4. rewrite H12. 
+    rewrite Pregmap.gso; auto with ppcgen.
+  unfold rs6; auto with ppcgen.
+  change (rs6 PC) with (ms m0). 
+  generalize H. destruct (ms m0); try congruence.
+  predSpec Int.eq Int.eq_spec i Int.zero; intros; congruence.
+  (* direct call *)
+  set (rs2 := nextinstr (rs#GPR12 <- (parent_ra s))).
+  set (rs3 := nextinstr (rs2#LR <- (parent_ra s))).
+  set (rs4 := nextinstr (rs3#GPR1 <- (parent_sp s))).
+  set (rs5 := rs4#PC <- (Vptr f' Int.zero)).
+  assert (exec_straight tge (transl_function f)
+            (transl_code f (Mtailcall sig (inr mreg i) :: c)) rs m 
+            (Pbs i :: transl_code f c) rs4 (free m stk)).
+  simpl. apply exec_straight_step with rs2 m. 
+  simpl. unfold load1. rewrite gpr_or_zero_not_zero. unfold const_low.
+  rewrite <- (sp_val _ _ _ AG). 
+  simpl. unfold load_stack in H2. simpl in H2. rewrite H2.
+  reflexivity. discriminate. reflexivity.
+  apply exec_straight_step with rs3 m.
+  simpl. reflexivity. reflexivity.
+  apply exec_straight_one. 
+  simpl. change (rs3 GPR1) with (rs GPR1). rewrite <- (sp_val _ _ _ AG).
+  unfold load_stack in H1; simpl in H1.
+  simpl. rewrite H1. reflexivity. reflexivity.
+  left; exists (State rs5 (free m stk)); split.
+  (* execution *)
+  eapply plus_right'. eapply exec_straight_exec; eauto.
+  econstructor.
+  change (rs4 PC) with (Val.add (Val.add (Val.add (rs PC) Vone) Vone) Vone).
+  rewrite <- H7; simpl. eauto.
+  eapply functions_transl; eauto. 
+  eapply find_instr_tail.
+  repeat (eapply code_tail_next_int; auto). eauto. 
+  simpl. unfold symbol_offset. rewrite symbols_preserved. rewrite H. 
+  reflexivity. traceEq.
+  (* match states *)
+  econstructor; eauto.
+  assert (AG3: agree ms (Vptr stk soff) rs3).
+    unfold rs3, rs2; auto 10 with ppcgen.
+  assert (AG4: agree ms (parent_sp s) rs4).
+    unfold rs4. apply agree_nextinstr.
+    split. reflexivity. intros. inv AG3. rewrite H12. 
+    rewrite Pregmap.gso; auto with ppcgen.
+  unfold rs5; auto with ppcgen.
+Qed.
+
+Lemma exec_Malloc_prop:
+  forall (s : list stackframe) (fb : block) (sp : val)
+         (c : list Mach.instruction) (ms : mreg -> val) (m : mem) (sz : int)
+         (m' : mem) (blk : block),
+  ms Conventions.loc_alloc_argument = Vint sz ->
+  alloc m 0 (Int.signed sz) = (m', blk) ->
+  exec_instr_prop (Machconcr.State s fb sp (Malloc :: c) ms m) E0
+         (Machconcr.State s fb sp c
+             (Regmap.set (Conventions.loc_alloc_result) (Vptr blk Int.zero) ms) m').
+Proof.
+  intros; red; intros; inv MS.
+  left; eapply exec_straight_steps; eauto with coqlib.
+  simpl. eapply transl_alloc_correct; eauto. 
+Qed.
+
+Lemma exec_Mgoto_prop:
+  forall (s : list stackframe) (fb : block) (f : function) (sp : val)
+         (lbl : Mach.label) (c : list Mach.instruction) (ms : Mach.regset)
+         (m : mem) (c' : Mach.code),
+  Genv.find_funct_ptr ge fb = Some (Internal f) ->
+  Mach.find_label lbl (fn_code f) = Some c' ->
+  exec_instr_prop (Machconcr.State s fb sp (Mgoto lbl :: c) ms m) E0
+                  (Machconcr.State s fb sp c' ms m).
+Proof.
+  intros; red; intros; inv MS.
+  assert (f0 = f) by congruence. subst f0.
+  inv AT. simpl in H3.
+  generalize (find_label_goto_label f lbl rs m _ _ _ FIND (sym_equal H1) H0).
+  intros [rs2 [GOTO [AT2 INV]]].
+  left; exists (State rs2 m); split.
+  apply plus_one. econstructor; eauto.
+  apply functions_transl; eauto.
+  eapply find_instr_tail; eauto.
+  simpl; auto.
+  econstructor; eauto.
+  eapply Mach.find_label_incl; eauto.
+  apply agree_exten_2 with rs; auto. 
+Qed.
+
+Lemma exec_Mcond_true_prop:
+  forall (s : list stackframe) (fb : block) (f : function) (sp : val)
+         (cond : condition) (args : list mreg) (lbl : Mach.label)
+         (c : list Mach.instruction) (ms : mreg -> val) (m : mem)
+         (c' : Mach.code),
+  eval_condition cond ms ## args m = Some true ->
+  Genv.find_funct_ptr ge fb = Some (Internal f) ->
+  Mach.find_label lbl (fn_code f) = Some c' ->
+  exec_instr_prop (Machconcr.State s fb sp (Mcond cond args lbl :: c) ms m) E0
+                  (Machconcr.State s fb sp c' ms m).
+Proof.
+  intros; red; intros; inv MS. assert (f0 = f) by congruence. subst f0.
+  generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
+  intro WTI. inv WTI.
+  pose (k1 := 
+         if snd (crbit_for_cond cond)
+         then Pbt (fst (crbit_for_cond cond)) lbl :: transl_code f c
+         else Pbf (fst (crbit_for_cond cond)) lbl :: transl_code f c).
+  generalize (transl_cond_correct tge (transl_function f)
+                cond args k1 ms sp rs m true H3 AG H).
+  simpl. intros [rs2 [EX [RES AG2]]].
+  inv AT. simpl in H5.
+  generalize (functions_transl _ _ H4); intro FN.
+  generalize (functions_transl_no_overflow _ _ H4); intro NOOV.
+  exploit exec_straight_steps_2; eauto. 
+  intros [ofs' [PC2 CT2]].
+  generalize (find_label_goto_label f lbl rs2 m _ _ _ FIND PC2 H1).
+  intros [rs3 [GOTO [AT3 INV3]]].
+  left; exists (State rs3 m); split.
+  eapply plus_right'. 
+  eapply exec_straight_steps_1; eauto.
+  caseEq (snd (crbit_for_cond cond)); intro ISSET; rewrite ISSET in RES.
+  econstructor; eauto.
+  eapply find_instr_tail. unfold k1 in CT2; rewrite ISSET in CT2. eauto.
+  simpl. rewrite RES. simpl. auto.
+  econstructor; eauto.
+  eapply find_instr_tail. unfold k1 in CT2; rewrite ISSET in CT2. eauto.
+  simpl. rewrite RES. simpl. auto.
+  traceEq.
+  econstructor; eauto. 
+  eapply Mach.find_label_incl; eauto.
+  apply agree_exten_2 with rs2; auto. 
+Qed.
+
+Lemma exec_Mcond_false_prop:
+  forall (s : list stackframe) (fb : block) (sp : val)
+         (cond : condition) (args : list mreg) (lbl : Mach.label)
+         (c : list Mach.instruction) (ms : mreg -> val) (m : mem),
+  eval_condition cond ms ## args m = Some false ->
+  exec_instr_prop (Machconcr.State s fb sp (Mcond cond args lbl :: c) ms m) E0
+                  (Machconcr.State s fb sp c ms m).
+Proof.
+  intros; red; intros; inv MS.
+  generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))).
+  intro WTI. inversion WTI.
+  pose (k1 := 
+         if snd (crbit_for_cond cond)
+         then Pbt (fst (crbit_for_cond cond)) lbl :: transl_code f c
+         else Pbf (fst (crbit_for_cond cond)) lbl :: transl_code f c).
+  generalize (transl_cond_correct tge (transl_function f)
+                cond args k1 ms sp rs m false H1 AG H).
+  simpl. intros [rs2 [EX [RES AG2]]].
+  left; eapply exec_straight_steps; eauto with coqlib.
+  exists (nextinstr rs2); split.
+  simpl. eapply exec_straight_trans. eexact EX. 
+  caseEq (snd (crbit_for_cond cond)); intro ISSET; rewrite ISSET in RES.
+  unfold k1; rewrite ISSET; apply exec_straight_one. 
+  simpl. rewrite RES. reflexivity.
+  reflexivity.
+  unfold k1; rewrite ISSET; apply exec_straight_one. 
+  simpl. rewrite RES. reflexivity.
+  reflexivity.
+  auto with ppcgen.
+Qed.
+
+Lemma exec_Mreturn_prop:
+  forall (s : list stackframe) (fb stk : block) (soff : int)
+         (c : list Mach.instruction) (ms : Mach.regset) (m : mem) (f: Mach.function),
+  Genv.find_funct_ptr ge fb = Some (Internal f) ->
+  load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) ->
+  load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) ->
+  exec_instr_prop (Machconcr.State s fb (Vptr stk soff) (Mreturn :: c) ms m) E0
+                  (Returnstate s ms (free m stk)).
+Proof.
+  intros; red; intros; inv MS.
+  assert (f0 = f) by congruence. subst f0.
+  set (rs2 := nextinstr (rs#GPR12 <- (parent_ra s))).
+  set (rs3 := nextinstr (rs2#LR <- (parent_ra s))).
+  set (rs4 := nextinstr (rs3#GPR1 <- (parent_sp s))).
+  set (rs5 := rs4#PC <- (parent_ra s)).
+  assert (exec_straight tge (transl_function f)
+            (transl_code f (Mreturn :: c)) rs m 
+            (Pblr :: transl_code f c) rs4 (free m stk)).
+  simpl. apply exec_straight_three with rs2 m rs3 m.
+  simpl. unfold load1. rewrite gpr_or_zero_not_zero. unfold const_low.
+  unfold load_stack in H1. simpl in H1. 
+  rewrite <- (sp_val _ _ _ AG). simpl. rewrite H1.
+  reflexivity. discriminate.
+  unfold rs3. change (parent_ra s) with rs2#GPR12. reflexivity.
+  simpl. change (rs3 GPR1) with (rs GPR1). rewrite <- (sp_val _ _ _ AG).
+  simpl. 
+  unfold load_stack in H0. simpl in H0.
+  rewrite H0. reflexivity.
+  reflexivity. reflexivity. reflexivity.
+  left; exists (State rs5 (free m stk)); split.
+  (* execution *)
+  apply plus_right' with E0 (State rs4 (free m stk)) E0.
+  eapply exec_straight_exec; eauto.
+  inv AT. econstructor.
+  change (rs4 PC) with (Val.add (Val.add (Val.add (rs PC) Vone) Vone) Vone). 
+  rewrite <- H3. simpl. eauto.
+  apply functions_transl; eauto.
+  generalize (functions_transl_no_overflow _ _ H4); intro NOOV.
+  simpl in H5. eapply find_instr_tail. 
+  eapply code_tail_next_int; auto.
+  eapply code_tail_next_int; auto.
+  eapply code_tail_next_int; eauto.
+  reflexivity. traceEq.
+  (* match states *)
+  econstructor; eauto. 
+  assert (AG3: agree ms (Vptr stk soff) rs3). 
+    unfold rs3, rs2; auto 10 with ppcgen.
+  assert (AG4: agree ms (parent_sp s) rs4).
+    split. reflexivity. intros. unfold rs4. 
+    rewrite nextinstr_inv. rewrite Pregmap.gso.
+    elim AG3; auto. auto with ppcgen. auto with ppcgen.
+  unfold rs5; auto with ppcgen.
+Qed.
+
+Hypothesis wt_prog: wt_program prog.
+
+Lemma exec_function_internal_prop:
+  forall (s : list stackframe) (fb : block) (ms : Mach.regset)
+         (m : mem) (f : function) (m1 m2 m3 : mem) (stk : block),
+  Genv.find_funct_ptr ge fb = Some (Internal f) ->
+  alloc m (- fn_framesize f) (fn_stacksize f) = (m1, stk) ->
+  let sp := Vptr stk (Int.repr (- fn_framesize f)) in
+  store_stack m1 sp Tint f.(fn_link_ofs) (parent_sp s) = Some m2 ->
+  store_stack m2 sp Tint f.(fn_retaddr_ofs) (parent_ra s) = Some m3 ->
+  exec_instr_prop (Machconcr.Callstate s fb ms m) E0
+                  (Machconcr.State s fb sp (fn_code f) ms m3).
+Proof.
+  intros; red; intros; inv MS.
+  assert (WTF: wt_function f).
+    generalize (Genv.find_funct_ptr_prop wt_fundef wt_prog H); intro TY.
+    inversion TY; auto.
+  exploit functions_transl; eauto. intro TFIND.
+  generalize (functions_transl_no_overflow _ _ H); intro NOOV.
+  set (rs2 := nextinstr (rs#GPR1 <- sp #GPR12 <- Vundef)).
+  set (rs3 := nextinstr (rs2#GPR12 <- (parent_ra s))).
+  set (rs4 := nextinstr rs3).
+  (* Execution of function prologue *)
+  assert (EXEC_PROLOGUE:
+            exec_straight tge (transl_function f)
+              (transl_function f) rs m
+              (transl_code f (fn_code f)) rs4 m3).
+  unfold transl_function at 2. 
+  apply exec_straight_three with rs2 m2 rs3 m2.
+  unfold exec_instr. rewrite H0. fold sp.
+  unfold store_stack in H1. simpl chunk_of_type in H1. 
+  rewrite <- (sp_val _ _ _ AG). rewrite H1. reflexivity.
+  simpl. change (rs2 LR) with (rs LR). rewrite ATLR. reflexivity.
+  simpl. unfold store1. rewrite gpr_or_zero_not_zero. 
+  unfold const_low. change (rs3 GPR1) with sp. change (rs3 GPR12) with (parent_ra s).
+  unfold store_stack in H2. simpl chunk_of_type in H2. rewrite H2. reflexivity.
+  discriminate. reflexivity. reflexivity. reflexivity.
+  (* Agreement at end of prologue *)
+  assert (AT4: transl_code_at_pc rs4#PC fb f f.(fn_code)).
+    change (rs4 PC) with (Val.add (Val.add (Val.add (rs PC) Vone) Vone) Vone).
+    rewrite ATPC. simpl. constructor. auto.
+    eapply code_tail_next_int; auto.
+    eapply code_tail_next_int; auto.
+    eapply code_tail_next_int; auto.
+    change (Int.unsigned Int.zero) with 0. 
+    unfold transl_function. constructor.
+  assert (AG2: agree ms sp rs2).
+    split. reflexivity. 
+    intros. unfold rs2. rewrite nextinstr_inv. 
+    repeat (rewrite Pregmap.gso). elim AG; auto.
+    auto with ppcgen. auto with ppcgen. auto with ppcgen.
+  assert (AG4: agree ms sp rs4).
+    unfold rs4, rs3; auto with ppcgen.
+  left; exists (State rs4 m3); split.
+  (* execution *)
+  eapply exec_straight_steps_1; eauto.
+  change (Int.unsigned Int.zero) with 0. constructor.
+  (* match states *)
+  econstructor; eauto with coqlib.
+Qed.
+
+Lemma exec_function_external_prop:
+  forall (s : list stackframe) (fb : block) (ms : Mach.regset)
+         (m : mem) (t0 : trace) (ms' : RegEq.t -> val)
+         (ef : external_function) (args : list val) (res : val),
+  Genv.find_funct_ptr ge fb = Some (External ef) ->
+  event_match ef args t0 res ->
+  Machconcr.extcall_arguments ms m (parent_sp s) (ef_sig ef) args ->
+  ms' = Regmap.set (Conventions.loc_result (ef_sig ef)) res ms ->
+  exec_instr_prop (Machconcr.Callstate s fb ms m)
+               t0 (Machconcr.Returnstate s ms' m).
+Proof.
+  intros; red; intros; inv MS.
+  exploit functions_translated; eauto.
+  intros [tf [A B]]. simpl in B. inv B. 
+  left; exists (State (rs#(loc_external_result (ef_sig ef)) <- res #PC <- (rs LR))
+                m); split.
+  apply plus_one. eapply exec_step_external; eauto. 
+  eapply extcall_arguments_match; eauto. 
+  econstructor; eauto.
+  unfold loc_external_result. auto with ppcgen.
+Qed.
+
+Lemma exec_return_prop:
+  forall (s : list stackframe) (fb : block) (sp ra : val)
+         (c : Mach.code) (ms : Mach.regset) (m : mem),
+  exec_instr_prop (Machconcr.Returnstate (Stackframe fb sp ra c :: s) ms m) E0
+                  (Machconcr.State s fb sp c ms m).
+Proof.
+  intros; red; intros; inv MS. inv STACKS. simpl in *.
+  right. split. omega. split. auto. 
+  econstructor; eauto. rewrite ATPC; auto.  
+Qed.
+
+Theorem transf_instr_correct:
+  forall s1 t s2, Machconcr.step ge s1 t s2 ->
+  exec_instr_prop s1 t s2.
+Proof
+  (Machconcr.step_ind ge exec_instr_prop
+           exec_Mlabel_prop
+           exec_Mgetstack_prop
+           exec_Msetstack_prop
+           exec_Mgetparam_prop
+           exec_Mop_prop
+           exec_Mload_prop
+           exec_Mstore_prop
+           exec_Mcall_prop
+           exec_Mtailcall_prop
+           exec_Malloc_prop
+           exec_Mgoto_prop
+           exec_Mcond_true_prop
+           exec_Mcond_false_prop
+           exec_Mreturn_prop
+           exec_function_internal_prop
+           exec_function_external_prop
+           exec_return_prop).
+
+Lemma transf_initial_states:
+  forall st1, Machconcr.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.
+  replace (symbol_offset (Genv.globalenv tprog) (prog_main tprog) Int.zero)
+     with (Vptr fb Int.zero).
+  rewrite (Genv.init_mem_transf_partial _ _ TRANSF).
+  econstructor; eauto. constructor.
+  split. auto. intros. repeat rewrite Pregmap.gso; auto with ppcgen.
+  unfold symbol_offset. 
+  rewrite (transform_partial_program_main _ _ TRANSF). 
+  rewrite symbols_preserved. unfold ge; rewrite H0. auto.
+Qed.
+
+Lemma transf_final_states:
+  forall st1 st2 r, 
+  match_states st1 st2 -> Machconcr.final_state st1 r -> Asm.final_state st2 r.
+Proof.
+  intros. inv H0. inv H. constructor. auto. 
+  compute in H1. 
+  rewrite (ireg_val _ _ _ R3 AG) in H1. auto. auto.
+Qed.
+
+Theorem transf_program_correct:
+  forall (beh: program_behavior),
+  Machconcr.exec_program prog beh -> Asm.exec_program tprog beh.
+Proof.
+  unfold Machconcr.exec_program, Asm.exec_program; intros.
+  eapply simulation_star_preservation with (measure := measure); eauto.
+  eexact transf_initial_states.
+  eexact transf_final_states.
+  exact transf_instr_correct. 
+Qed.
+
+End PRESERVATION.
diff --git a/powerpc/Asmgenproof1.v b/powerpc/Asmgenproof1.v
new file mode 100644
index 00000000..c17cb737
--- /dev/null
+++ b/powerpc/Asmgenproof1.v
@@ -0,0 +1,1632 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              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 PPC generation: auxiliary results. *)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Mem.
+Require Import Globalenvs.
+Require Import Op.
+Require Import Locations.
+Require Import Mach.
+Require Import Machconcr.
+Require Import Machtyping.
+Require Import Asm.
+Require Import Asmgen.
+Require Conventions.
+
+(** * Properties of low half/high half decomposition *)
+
+Lemma high_half_zero:
+  forall v, Val.add (high_half v) Vzero = high_half v.
+Proof.
+  intros. generalize (high_half_type v).
+  rewrite Val.add_commut. 
+  case (high_half v); simpl; intros; try contradiction.
+  auto. 
+  rewrite Int.add_commut; rewrite Int.add_zero; auto. 
+  rewrite Int.add_zero; auto. 
+Qed.
+
+Lemma low_high_u:
+  forall n, Int.or (Int.shl (high_u n) (Int.repr 16)) (low_u n) = n.
+Proof.
+  intros. unfold high_u, low_u.
+  rewrite Int.shl_rolm. rewrite Int.shru_rolm. 
+  rewrite Int.rolm_rolm. 
+  change (Int.modu (Int.add (Int.sub (Int.repr (Z_of_nat wordsize)) (Int.repr 16))
+                            (Int.repr 16))
+                   (Int.repr (Z_of_nat wordsize)))
+    with (Int.zero).
+  rewrite Int.rolm_zero. rewrite <- Int.and_or_distrib.
+  exact (Int.and_mone n).
+  reflexivity. reflexivity.
+Qed.
+
+Lemma low_high_u_xor:
+  forall n, Int.xor (Int.shl (high_u n) (Int.repr 16)) (low_u n) = n.
+Proof.
+  intros. unfold high_u, low_u.
+  rewrite Int.shl_rolm. rewrite Int.shru_rolm. 
+  rewrite Int.rolm_rolm. 
+  change (Int.modu (Int.add (Int.sub (Int.repr (Z_of_nat wordsize)) (Int.repr 16))
+                            (Int.repr 16))
+                   (Int.repr (Z_of_nat wordsize)))
+    with (Int.zero).
+  rewrite Int.rolm_zero. rewrite <- Int.and_xor_distrib.
+  exact (Int.and_mone n).
+  reflexivity. reflexivity.
+Qed.
+
+Lemma low_high_s:
+  forall n, Int.add (Int.shl (high_s n) (Int.repr 16)) (low_s n) = n.
+Proof.
+  intros. rewrite Int.shl_mul_two_p. 
+  unfold high_s. 
+  rewrite <- (Int.divu_pow2 (Int.sub n (low_s n)) (Int.repr 65536) (Int.repr 16)).
+  change (two_p (Int.unsigned (Int.repr 16))) with 65536.
+
+  assert (forall x y, y > 0 -> (x - x mod y) mod y = 0).
+  intros. apply Zmod_unique with (x / y). 
+  generalize (Z_div_mod_eq x y H). intro. rewrite Zmult_comm. omega.
+  omega.
+
+  assert (Int.modu (Int.sub n (low_s n)) (Int.repr 65536) = Int.zero).
+  unfold Int.modu, Int.zero. decEq. 
+  change (Int.unsigned (Int.repr 65536)) with 65536.
+  unfold Int.sub. 
+  assert (forall a b, Int.eqm a b -> b mod 65536 = 0 -> a mod 65536 = 0).
+  intros a b [k EQ] H1. rewrite EQ. 
+  change modulus with (65536 * 65536). 
+  rewrite Zmult_assoc. rewrite Zplus_comm. rewrite Z_mod_plus. auto.
+  omega.
+  eapply H0. apply Int.eqm_sym. apply Int.eqm_unsigned_repr. 
+  unfold low_s. unfold Int.sign_ext. 
+  change (two_p 16) with 65536. change (two_p (16-1)) with 32768. 
+  set (N := Int.unsigned n).
+  case (zlt (N mod 65536) 32768); intro.
+  apply H0 with (N - N mod 65536). auto with ints.
+  apply H. omega.
+  apply H0 with (N - (N mod 65536 - 65536)). auto with ints.
+  replace (N - (N mod 65536 - 65536))
+     with ((N - N mod 65536) + 1 * 65536).
+  rewrite Z_mod_plus. apply H. omega. omega. ring. 
+
+  assert (Int.repr 65536 <> Int.zero). compute. congruence. 
+  generalize (Int.modu_divu_Euclid (Int.sub n (low_s n)) (Int.repr 65536) H1).
+  rewrite H0. rewrite Int.add_zero. intro. rewrite <- H2. 
+  rewrite Int.sub_add_opp. rewrite Int.add_assoc. 
+  replace (Int.add (Int.neg (low_s n)) (low_s n)) with Int.zero.
+  apply Int.add_zero. symmetry. rewrite Int.add_commut. 
+  rewrite <- Int.sub_add_opp. apply Int.sub_idem.
+
+  reflexivity.
+Qed.
+
+(** * Correspondence between Mach registers and PPC registers *)
+
+Hint Extern 2 (_ <> _) => discriminate: ppcgen.
+
+(** Mapping from Mach registers to PPC registers. *)
+
+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.
+
+(** Characterization of PPC registers that correspond to Mach registers. *)
+
+Definition is_data_reg (r: preg) : Prop :=
+  match r with
+  | IR GPR12 => False
+  | FR FPR13 => False
+  | PC => False    | LR => False    | CTR => False
+  | CR0_0 => False | CR0_1 => False | CR0_2 => False | CR0_3 => False
+  | CARRY => False
+  | _ => True
+  end.
+
+Lemma ireg_of_is_data_reg:
+  forall (r: mreg), is_data_reg (ireg_of r).
+Proof.
+  destruct r; exact I.
+Qed.
+
+Lemma freg_of_is_data_reg:
+  forall (r: mreg), is_data_reg (ireg_of r).
+Proof.
+  destruct r; exact I.
+Qed.
+
+Lemma preg_of_is_data_reg:
+  forall (r: mreg), is_data_reg (preg_of r).
+Proof.
+  destruct r; exact I.
+Qed.
+
+Lemma ireg_of_not_GPR1:
+  forall r, ireg_of r <> GPR1.
+Proof.
+  intro. case r; discriminate.
+Qed.
+Lemma ireg_of_not_GPR12:
+  forall r, ireg_of r <> GPR12.
+Proof.
+  intro. case r; discriminate.
+Qed.
+Lemma freg_of_not_FPR13:
+  forall r, freg_of r <> FPR13.
+Proof.
+  intro. case r; discriminate.
+Qed.
+Hint Resolve ireg_of_not_GPR1 ireg_of_not_GPR12 freg_of_not_FPR13: ppcgen.
+
+Lemma preg_of_not:
+  forall r1 r2, ~(is_data_reg r2) -> preg_of r1 <> r2.
+Proof.
+  intros; red; intro. subst r2. elim H. apply preg_of_is_data_reg.
+Qed.
+Hint Resolve preg_of_not: ppcgen.
+
+Lemma preg_of_not_GPR1:
+  forall r, preg_of r <> GPR1.
+Proof.
+  intro. case r; discriminate.
+Qed.
+Hint Resolve preg_of_not_GPR1: ppcgen.
+
+(** Agreement between Mach register sets and PPC register sets. *)
+
+Definition agree (ms: Mach.regset) (sp: val) (rs: Asm.regset) :=
+  rs#GPR1 = sp /\ forall r: mreg, ms r = rs#(preg_of r).
+
+Lemma preg_val:
+  forall ms sp rs r,
+  agree ms sp rs -> ms r = rs#(preg_of r).
+Proof.
+  intros. elim H. auto.
+Qed.
+  
+Lemma ireg_val:
+  forall ms sp rs r,
+  agree ms sp rs ->
+  mreg_type r = Tint ->
+  ms r = rs#(ireg_of r).
+Proof.
+  intros. elim H; intros.
+  generalize (H2 r). unfold preg_of. rewrite H0. auto.
+Qed.
+
+Lemma freg_val:
+  forall ms sp rs r,
+  agree ms sp rs ->
+  mreg_type r = Tfloat ->
+  ms r = rs#(freg_of r).
+Proof.
+  intros. elim H; intros.
+  generalize (H2 r). unfold preg_of. rewrite H0. auto.
+Qed.
+
+Lemma sp_val:
+  forall ms sp rs,
+  agree ms sp rs ->
+  sp = rs#GPR1.
+Proof.
+  intros. elim H; auto.
+Qed.
+
+Lemma agree_exten_1:
+  forall ms sp rs rs',
+  agree ms sp rs ->
+  (forall r, is_data_reg r -> rs'#r = rs#r) ->
+  agree ms sp rs'.
+Proof.
+  unfold agree; intros. elim H; intros.
+  split. rewrite H0. auto. exact I. 
+  intros. rewrite H0. auto. apply preg_of_is_data_reg.
+Qed.
+
+Lemma agree_exten_2:
+  forall ms sp rs rs',
+  agree ms sp rs ->
+  (forall r,
+     r <> IR GPR12 -> r <> FR FPR13 ->
+     r <> PC -> r <> LR -> r <> CTR ->
+     r <> CR0_0 -> r <> CR0_1 -> r <> CR0_2 -> r <> CR0_3 ->
+     r <> CARRY ->
+     rs'#r = rs#r) ->
+  agree ms sp rs'.
+Proof.
+  intros. apply agree_exten_1 with rs. auto.
+  intros. apply H0; (red; intro; subst r; elim H1).
+Qed.
+
+(** Preservation of register agreement under various assignments. *)
+
+Lemma agree_set_mreg:
+  forall ms sp rs r v,
+  agree ms sp rs ->
+  agree (Regmap.set r v ms) sp (rs#(preg_of r) <- v).
+Proof.
+  unfold agree; intros. elim H; intros; clear H.
+  split. rewrite Pregmap.gso. auto. apply sym_not_eq. apply preg_of_not_GPR1.
+  intros. unfold Regmap.set. case (RegEq.eq r0 r); intro.
+  subst r0. rewrite Pregmap.gss. auto.
+  rewrite Pregmap.gso. auto. red; intro. 
+  elim n. apply preg_of_injective; auto.
+Qed.
+Hint Resolve agree_set_mreg: ppcgen.
+
+Lemma agree_set_mireg:
+  forall ms sp rs r v,
+  agree ms sp (rs#(preg_of r) <- v) ->
+  mreg_type r = Tint ->
+  agree ms sp (rs#(ireg_of r) <- v).
+Proof.
+  intros. unfold preg_of in H. rewrite H0 in H. auto.
+Qed.
+Hint Resolve agree_set_mireg: ppcgen.
+
+Lemma agree_set_mfreg:
+  forall ms sp rs r v,
+  agree ms sp (rs#(preg_of r) <- v) ->
+  mreg_type r = Tfloat ->
+  agree ms sp (rs#(freg_of r) <- v).
+Proof.
+  intros. unfold preg_of in H. rewrite H0 in H. auto.
+Qed.
+Hint Resolve agree_set_mfreg: ppcgen.
+
+Lemma agree_set_other:
+  forall ms sp rs r v,
+  agree ms sp rs ->
+  ~(is_data_reg r) ->
+  agree ms sp (rs#r <- v).
+Proof.
+  intros. apply agree_exten_1 with rs.
+  auto. intros. apply Pregmap.gso. red; intro; subst r0; contradiction.
+Qed.
+Hint Resolve agree_set_other: ppcgen.
+
+Lemma agree_nextinstr:
+  forall ms sp rs,
+  agree ms sp rs -> agree ms sp (nextinstr rs).
+Proof.
+  intros. unfold nextinstr. apply agree_set_other. auto. auto.
+Qed.
+Hint Resolve agree_nextinstr: ppcgen.
+
+Lemma agree_set_mireg_twice:
+  forall ms sp rs r v v',
+  agree ms sp rs ->
+  mreg_type r = Tint ->
+  agree (Regmap.set r v ms) sp (rs #(ireg_of r) <- v' #(ireg_of r) <- v).
+Proof.
+  intros. replace (IR (ireg_of r)) with (preg_of r). elim H; intros.
+  split. repeat (rewrite Pregmap.gso; auto with ppcgen).
+  intros. case (mreg_eq r r0); intro.
+  subst r0. rewrite Regmap.gss. rewrite Pregmap.gss. auto.
+  assert (preg_of r <> preg_of r0). 
+    red; intro. elim n. apply preg_of_injective. auto.
+  rewrite Regmap.gso; auto.
+  repeat (rewrite Pregmap.gso; auto).
+  unfold preg_of. rewrite H0. auto.
+Qed.
+Hint Resolve agree_set_mireg_twice: ppcgen.
+
+Lemma agree_set_twice_mireg:
+  forall ms sp rs r v v',
+  agree (Regmap.set r v' ms) sp rs ->
+  mreg_type r = Tint ->
+  agree (Regmap.set r v ms) sp (rs#(ireg_of r) <- v).
+Proof.
+  intros. elim H; intros.
+  split. rewrite Pregmap.gso. auto. 
+  generalize (ireg_of_not_GPR1 r); congruence.
+  intros. generalize (H2 r0). 
+  case (mreg_eq r0 r); intro.
+  subst r0. repeat rewrite Regmap.gss. unfold preg_of; rewrite H0.
+  rewrite Pregmap.gss. auto.
+  repeat rewrite Regmap.gso; auto.
+  rewrite Pregmap.gso. auto. 
+  replace (IR (ireg_of r)) with (preg_of r).
+  red; intros. elim n. apply preg_of_injective; auto.
+  unfold preg_of. rewrite H0. auto.
+Qed.
+Hint Resolve agree_set_twice_mireg: ppcgen.
+
+Lemma agree_set_commut:
+  forall ms sp rs r1 r2 v1 v2,
+  r1 <> r2 ->
+  agree ms sp ((rs#r2 <- v2)#r1 <- v1) ->
+  agree ms sp ((rs#r1 <- v1)#r2 <- v2).
+Proof.
+  intros. apply agree_exten_1 with ((rs#r2 <- v2)#r1 <- v1). auto.
+  intros. 
+  case (preg_eq r r1); intro.
+  subst r1. rewrite Pregmap.gss. rewrite Pregmap.gso. rewrite Pregmap.gss.
+  auto. auto.
+  case (preg_eq r r2); intro.
+  subst r2. rewrite Pregmap.gss. rewrite Pregmap.gso. rewrite Pregmap.gss.
+  auto. auto.
+  repeat (rewrite Pregmap.gso; auto). 
+Qed. 
+Hint Resolve agree_set_commut: ppcgen.
+
+Lemma agree_nextinstr_commut:
+  forall ms sp rs r v,
+  agree ms sp (rs#r <- v) ->
+  r <> PC ->
+  agree ms sp ((nextinstr rs)#r <- v).
+Proof.
+  intros. unfold nextinstr. apply agree_set_commut. auto. 
+  apply agree_set_other. auto. auto. 
+Qed.
+Hint Resolve agree_nextinstr_commut: ppcgen.
+
+Lemma agree_set_mireg_exten:
+  forall ms sp rs r v (rs': regset),
+  agree ms sp rs ->
+  mreg_type r = Tint ->
+  rs'#(ireg_of r) = v ->
+  (forall r', 
+     r' <> IR GPR12 -> r' <> FR FPR13 ->
+     r' <> PC -> r' <> LR -> r' <> CTR ->
+     r' <> CR0_0 -> r' <> CR0_1 -> r' <> CR0_2 -> r' <> CR0_3 ->
+     r' <> CARRY ->
+     r' <> IR (ireg_of r) -> rs'#r' = rs#r') ->
+  agree (Regmap.set r v ms) sp rs'.
+Proof.
+  intros. apply agree_exten_2 with (rs#(ireg_of r) <- v).
+  auto with ppcgen.
+  intros. unfold Pregmap.set. case (PregEq.eq r0 (ireg_of r)); intro.
+  subst r0. auto. apply H2; auto.
+Qed.
+
+(** Useful properties of the PC and GPR0 registers. *)
+
+Lemma nextinstr_inv:
+  forall r rs, r <> PC -> (nextinstr rs)#r = rs#r.
+Proof.
+  intros. unfold nextinstr. apply Pregmap.gso. auto.
+Qed.
+Hint Resolve nextinstr_inv: ppcgen.
+
+Lemma nextinstr_set_preg:
+  forall rs m v,
+  (nextinstr (rs#(preg_of m) <- v))#PC = Val.add rs#PC Vone.
+Proof.
+  intros. unfold nextinstr. rewrite Pregmap.gss. 
+  rewrite Pregmap.gso. auto. apply sym_not_eq. auto with ppcgen.
+Qed.
+Hint Resolve nextinstr_set_preg: ppcgen.
+
+Lemma gpr_or_zero_not_zero:
+  forall rs r, r <> GPR0 -> gpr_or_zero rs r = rs#r.
+Proof.
+  intros. unfold gpr_or_zero. case (ireg_eq r GPR0); tauto.
+Qed.
+Lemma gpr_or_zero_zero:
+  forall rs, gpr_or_zero rs GPR0 = Vzero.
+Proof.
+  intros. reflexivity.
+Qed.
+Hint Resolve gpr_or_zero_not_zero gpr_or_zero_zero: ppcgen.
+
+(** Connection between Mach and Asm calling conventions for external
+    functions. *)
+
+Lemma extcall_arg_match:
+  forall ms sp rs m l v,
+  agree ms sp rs ->
+  Machconcr.extcall_arg ms m sp l v ->
+  Asm.extcall_arg rs m l v.
+Proof.
+  intros. inv H0. 
+  rewrite (preg_val _ _ _ r H). constructor.
+  rewrite (sp_val _ _ _ H) in H1.
+  destruct ty; unfold load_stack in H1.
+  econstructor. reflexivity. assumption.
+  econstructor. reflexivity. assumption.
+Qed.
+
+Lemma extcall_args_match:
+  forall ms sp rs m, agree ms sp rs ->
+  forall ll vl,
+  Machconcr.extcall_args ms m sp ll vl ->
+  Asm.extcall_args rs m ll vl.
+Proof.
+  induction 2; constructor; auto. eapply extcall_arg_match; eauto.
+Qed.
+
+Lemma extcall_arguments_match:
+  forall ms m sp rs sg args,
+  agree ms sp rs ->
+  Machconcr.extcall_arguments ms m sp sg args ->
+  Asm.extcall_arguments rs m sg args.
+Proof.
+  unfold Machconcr.extcall_arguments, Asm.extcall_arguments; intros.
+  eapply extcall_args_match; eauto.
+Qed.
+
+(** * Execution of straight-line code *)
+
+Section STRAIGHTLINE.
+
+Variable ge: genv.
+Variable fn: code.
+
+(** Straight-line code is composed of PPC 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: code -> regset -> mem -> 
+                         code -> regset -> mem -> Prop :=
+  | exec_straight_one:
+      forall i1 c rs1 m1 rs2 m2,
+      exec_instr ge fn i1 rs1 m1 = OK rs2 m2 ->
+      rs2#PC = Val.add rs1#PC Vone ->
+      exec_straight (i1 :: c) rs1 m1 c rs2 m2
+  | exec_straight_step:
+      forall i c rs1 m1 rs2 m2 c' rs3 m3,
+      exec_instr ge fn i rs1 m1 = OK rs2 m2 ->
+      rs2#PC = Val.add rs1#PC Vone ->
+      exec_straight c rs2 m2 c' rs3 m3 ->
+      exec_straight (i :: c) rs1 m1 c' rs3 m3.
+
+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.
+
+Lemma exec_straight_two:
+  forall i1 i2 c rs1 m1 rs2 m2 rs3 m3,
+  exec_instr ge fn i1 rs1 m1 = OK rs2 m2 ->
+  exec_instr ge fn i2 rs2 m2 = OK rs3 m3 ->
+  rs2#PC = Val.add rs1#PC Vone ->
+  rs3#PC = Val.add rs2#PC Vone ->
+  exec_straight (i1 :: i2 :: 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_instr ge fn i1 rs1 m1 = OK rs2 m2 ->
+  exec_instr ge fn i2 rs2 m2 = OK rs3 m3 ->
+  exec_instr ge fn i3 rs3 m3 = OK rs4 m4 ->
+  rs2#PC = Val.add rs1#PC Vone ->
+  rs3#PC = Val.add rs2#PC Vone ->
+  rs4#PC = Val.add rs3#PC Vone ->
+  exec_straight (i1 :: i2 :: i3 :: c) rs1 m1 c rs4 m4.
+Proof.
+  intros. apply exec_straight_step with rs2 m2; auto.
+  eapply exec_straight_two; eauto.
+Qed.
+
+(** * Correctness of PowerPC constructor functions *)
+
+(** Properties of comparisons. *)
+
+Lemma compare_float_spec:
+  forall rs v1 v2,
+  let rs1 := nextinstr (compare_float rs v1 v2) in
+     rs1#CR0_0 = Val.cmpf Clt v1 v2
+  /\ rs1#CR0_1 = Val.cmpf Cgt v1 v2
+  /\ rs1#CR0_2 = Val.cmpf Ceq v1 v2
+  /\ forall r', r' <> PC -> r' <> CR0_0 -> r' <> CR0_1 ->
+       r' <> CR0_2 -> r' <> CR0_3 -> rs1#r' = rs#r'.
+Proof.
+  intros. unfold rs1.
+  split. reflexivity.
+  split. reflexivity.
+  split. reflexivity.
+  intros. rewrite nextinstr_inv; auto.
+  unfold compare_float. repeat (rewrite Pregmap.gso; auto).
+Qed.
+
+Lemma compare_sint_spec:
+  forall rs v1 v2,
+  let rs1 := nextinstr (compare_sint rs v1 v2) in
+     rs1#CR0_0 = Val.cmp Clt v1 v2
+  /\ rs1#CR0_1 = Val.cmp Cgt v1 v2
+  /\ rs1#CR0_2 = Val.cmp Ceq v1 v2
+  /\ forall r', r' <> PC -> r' <> CR0_0 -> r' <> CR0_1 ->
+       r' <> CR0_2 -> r' <> CR0_3 -> rs1#r' = rs#r'.
+Proof.
+  intros. unfold rs1.
+  split. reflexivity.
+  split. reflexivity.
+  split. reflexivity.
+  intros. rewrite nextinstr_inv; auto.
+  unfold compare_sint. repeat (rewrite Pregmap.gso; auto).
+Qed.
+
+Lemma compare_uint_spec:
+  forall rs v1 v2,
+  let rs1 := nextinstr (compare_uint rs v1 v2) in
+     rs1#CR0_0 = Val.cmpu Clt v1 v2
+  /\ rs1#CR0_1 = Val.cmpu Cgt v1 v2
+  /\ rs1#CR0_2 = Val.cmpu Ceq v1 v2
+  /\ forall r', r' <> PC -> r' <> CR0_0 -> r' <> CR0_1 ->
+       r' <> CR0_2 -> r' <> CR0_3 -> rs1#r' = rs#r'.
+Proof.
+  intros. unfold rs1.
+  split. reflexivity.
+  split. reflexivity.
+  split. reflexivity.
+  intros. rewrite nextinstr_inv; auto.
+  unfold compare_uint. repeat (rewrite Pregmap.gso; auto).
+Qed.
+
+(** Loading a constant. *)
+
+Lemma loadimm_correct:
+  forall r n k rs m,
+  exists rs',
+     exec_straight (loadimm r n k) rs m  k rs' m
+  /\ rs'#r = Vint n
+  /\ forall r': preg, r' <> r -> r' <> PC -> rs'#r' = rs#r'.
+Proof.
+  intros. unfold loadimm.
+  case (Int.eq (high_s n) Int.zero).
+  (* addi *)
+  exists (nextinstr (rs#r <- (Vint n))).
+  split. apply exec_straight_one. 
+  simpl. rewrite Int.add_commut. rewrite Int.add_zero. reflexivity.
+  reflexivity. 
+  split. rewrite nextinstr_inv; auto with ppcgen.
+   apply Pregmap.gss. 
+  intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto.
+  (* addis *)
+  generalize (Int.eq_spec (low_s n) Int.zero); case (Int.eq (low_s n) Int.zero); intro.
+  exists (nextinstr (rs#r <- (Vint n))).
+  split. apply exec_straight_one. 
+  simpl. rewrite Int.add_commut. 
+  rewrite <- H. rewrite low_high_s. reflexivity.
+  reflexivity. 
+  split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. 
+  intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto.
+  (* addis + ori *)
+  pose (rs1 := nextinstr (rs#r <- (Vint (Int.shl (high_u n) (Int.repr 16))))).
+  exists (nextinstr (rs1#r <- (Vint n))).
+  split. eapply exec_straight_two. 
+  simpl. rewrite Int.add_commut. rewrite Int.add_zero. reflexivity.
+  simpl. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. 
+  unfold Val.or. rewrite low_high_u. reflexivity.
+  reflexivity. reflexivity.
+  split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. 
+  intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto.
+  unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto.
+Qed.
+
+(** Add integer immediate. *)
+
+Lemma addimm_1_correct:
+  forall r1 r2 n k rs m,
+  r1 <> GPR0 ->
+  r2 <> GPR0 ->
+  exists rs',
+     exec_straight (addimm_1 r1 r2 n k) rs m  k rs' m
+  /\ rs'#r1 = Val.add rs#r2 (Vint n)
+  /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'.
+Proof.
+  intros. unfold addimm_1.
+  (* addi *)
+  case (Int.eq (high_s n) Int.zero).
+  exists (nextinstr (rs#r1 <- (Val.add rs#r2 (Vint n)))).
+  split. apply exec_straight_one. 
+  simpl. rewrite gpr_or_zero_not_zero; auto.
+  reflexivity. 
+  split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. 
+  intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. 
+  (* addis *)
+  generalize (Int.eq_spec (low_s n) Int.zero); case (Int.eq (low_s n) Int.zero); intro.
+  exists (nextinstr (rs#r1 <- (Val.add rs#r2 (Vint n)))).
+  split. apply exec_straight_one.
+  simpl. rewrite gpr_or_zero_not_zero; auto.
+  generalize (low_high_s n). rewrite H1. rewrite Int.add_zero. intro.
+  rewrite H2. auto.
+  reflexivity.
+  split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. 
+  intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto.
+  (* addis + addi *)
+  pose (rs1 := nextinstr (rs#r1 <- (Val.add rs#r2 (Vint (Int.shl (high_s n) (Int.repr 16)))))).
+  exists (nextinstr (rs1#r1 <- (Val.add rs#r2 (Vint n)))).
+  split. apply exec_straight_two with rs1 m.
+  simpl. rewrite gpr_or_zero_not_zero; auto. 
+  simpl. rewrite gpr_or_zero_not_zero; auto.
+  unfold rs1 at 1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss.
+  rewrite Val.add_assoc. simpl. rewrite low_high_s. auto.
+  reflexivity. reflexivity. 
+  split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. 
+  intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto.
+  unfold rs1. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto.
+Qed. 
+
+Lemma addimm_2_correct:
+  forall r1 r2 n k rs m,
+  r2 <> GPR12 ->
+  exists rs',
+     exec_straight (addimm_2 r1 r2 n k) rs m  k rs' m
+  /\ rs'#r1 = Val.add rs#r2 (Vint n)
+  /\ forall r': preg, r' <> r1 -> r' <> GPR12 -> r' <> PC -> rs'#r' = rs#r'.
+Proof.
+  intros. unfold addimm_2.
+  generalize (loadimm_correct GPR12 n (Padd r1 r2 GPR12 :: k) rs m).
+  intros [rs1 [EX [RES OTHER]]].
+  exists (nextinstr (rs1#r1 <- (Val.add rs#r2 (Vint n)))).
+  split. eapply exec_straight_trans. eexact EX. 
+  apply exec_straight_one. simpl. rewrite RES. rewrite OTHER.
+  auto. congruence. discriminate.
+  reflexivity. 
+  split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss.
+  intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto.
+Qed.
+
+Lemma addimm_correct:
+  forall r1 r2 n k rs m,
+  r2 <> GPR12 ->
+  exists rs',
+     exec_straight (addimm r1 r2 n k) rs m  k rs' m
+  /\ rs'#r1 = Val.add rs#r2 (Vint n)
+  /\ forall r': preg, r' <> r1 -> r' <> GPR12 -> r' <> PC -> rs'#r' = rs#r'.
+Proof.
+  intros. unfold addimm.
+  case (ireg_eq r1 GPR0); intro.
+  apply addimm_2_correct; auto.
+  case (ireg_eq r2 GPR0); intro.
+  apply addimm_2_correct; auto.
+  generalize (addimm_1_correct r1 r2 n k rs m n0 n1).  
+  intros [rs' [EX [RES OTH]]]. exists rs'. intuition. 
+Qed.
+
+(** And integer immediate. *)
+
+Lemma andimm_correct:
+  forall r1 r2 n k (rs : regset) m,
+  r2 <> GPR12 ->
+  let v := Val.and rs#r2 (Vint n) in
+  exists rs',
+     exec_straight (andimm r1 r2 n k) rs m  k rs' m
+  /\ rs'#r1 = v
+  /\ rs'#CR0_2 = Val.cmp Ceq v Vzero
+  /\ forall r': preg,
+       r' <> r1 -> r' <> GPR12 -> r' <> PC ->
+       r' <> CR0_0 -> r' <> CR0_1 -> r' <> CR0_2 -> r' <> CR0_3 ->
+       rs'#r' = rs#r'.
+Proof.
+  intros. unfold andimm.
+  case (Int.eq (high_u n) Int.zero).
+  (* andi *)
+  exists (nextinstr (compare_sint (rs#r1 <- v) v Vzero)).
+  generalize (compare_sint_spec (rs#r1 <- v) v Vzero).
+  intros [A [B [C D]]].
+  split. apply exec_straight_one. reflexivity. reflexivity.
+  split. rewrite D; try discriminate. apply Pregmap.gss. 
+  split. auto.
+  intros. rewrite D; auto. apply Pregmap.gso; auto.
+  (* andis *)
+  generalize (Int.eq_spec (low_u n) Int.zero);
+  case (Int.eq (low_u n) Int.zero); intro.
+  exists (nextinstr (compare_sint (rs#r1 <- v) v Vzero)).
+  generalize (compare_sint_spec (rs#r1 <- v) v Vzero).
+  intros [A [B [C D]]].
+  split. apply exec_straight_one. simpl.
+  generalize (low_high_u n). rewrite H0. rewrite Int.or_zero. 
+  intro. rewrite H1. reflexivity. reflexivity.
+  split. rewrite D; try discriminate. apply Pregmap.gss. 
+  split. auto.
+  intros. rewrite D; auto. apply Pregmap.gso; auto.
+  (* loadimm + and *)
+  generalize (loadimm_correct GPR12 n (Pand_ r1 r2 GPR12 :: k) rs m).
+  intros [rs1 [EX1 [RES1 OTHER1]]].
+  exists (nextinstr (compare_sint (rs1#r1 <- v) v Vzero)).
+  generalize (compare_sint_spec (rs1#r1 <- v) v Vzero).
+  intros [A [B [C D]]].
+  split. eapply exec_straight_trans. eexact EX1. 
+  apply exec_straight_one. simpl. rewrite RES1. 
+  rewrite (OTHER1 r2). reflexivity. congruence. congruence.
+  reflexivity. 
+  split. rewrite D; try discriminate. apply Pregmap.gss. 
+  split. auto.
+  intros. rewrite D; auto. rewrite Pregmap.gso; auto.
+Qed.
+
+(** Or integer immediate. *)
+
+Lemma orimm_correct:
+  forall r1 (r2: ireg) n k (rs : regset) m,
+  let v := Val.or rs#r2 (Vint n) in
+  exists rs',
+     exec_straight (orimm r1 r2 n k) rs m  k rs' m
+  /\ rs'#r1 = v
+  /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'.
+Proof.
+  intros. unfold orimm.
+  case (Int.eq (high_u n) Int.zero).
+  (* ori *)
+  exists (nextinstr (rs#r1 <- v)).
+  split. apply exec_straight_one. reflexivity. reflexivity.
+  split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss.
+  intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto.
+  (* oris *)
+  generalize (Int.eq_spec (low_u n) Int.zero);
+  case (Int.eq (low_u n) Int.zero); intro.
+  exists (nextinstr (rs#r1 <- v)).
+  split. apply exec_straight_one. simpl.
+  generalize (low_high_u n). rewrite H. rewrite Int.or_zero. 
+  intro. rewrite H0. reflexivity. reflexivity.
+  split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss.
+  intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto.
+  (* oris + ori *)
+  pose (rs1 := nextinstr (rs#r1 <- (Val.or rs#r2 (Vint (Int.shl (high_u n) (Int.repr 16)))))).
+  exists (nextinstr (rs1#r1 <- v)).
+  split. apply exec_straight_two with rs1 m.
+  reflexivity. simpl. unfold rs1 at 1. 
+  rewrite nextinstr_inv; auto with ppcgen.
+  rewrite Pregmap.gss. rewrite Val.or_assoc. simpl. 
+  rewrite low_high_u. reflexivity. reflexivity. reflexivity. 
+  split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss.
+  intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto.
+  unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto.
+Qed.
+
+(** Xor integer immediate. *)
+
+Lemma xorimm_correct:
+  forall r1 (r2: ireg) n k (rs : regset) m,
+  let v := Val.xor rs#r2 (Vint n) in
+  exists rs',
+     exec_straight (xorimm r1 r2 n k) rs m  k rs' m
+  /\ rs'#r1 = v
+  /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'.
+Proof.
+  intros. unfold xorimm.
+  case (Int.eq (high_u n) Int.zero).
+  (* xori *)
+  exists (nextinstr (rs#r1 <- v)).
+  split. apply exec_straight_one. reflexivity. reflexivity.
+  split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss.
+  intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto.
+  (* xoris *)
+  generalize (Int.eq_spec (low_u n) Int.zero);
+  case (Int.eq (low_u n) Int.zero); intro.
+  exists (nextinstr (rs#r1 <- v)).
+  split. apply exec_straight_one. simpl.
+  generalize (low_high_u_xor n). rewrite H. rewrite Int.xor_zero. 
+  intro. rewrite H0. reflexivity. reflexivity.
+  split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss.
+  intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto.
+  (* xoris + xori *)
+  pose (rs1 := nextinstr (rs#r1 <- (Val.xor rs#r2 (Vint (Int.shl (high_u n) (Int.repr 16)))))).
+  exists (nextinstr (rs1#r1 <- v)).
+  split. apply exec_straight_two with rs1 m.
+  reflexivity. simpl. unfold rs1 at 1. 
+  rewrite nextinstr_inv; try discriminate. 
+  rewrite Pregmap.gss. rewrite Val.xor_assoc. simpl. 
+  rewrite low_high_u_xor. reflexivity. reflexivity. reflexivity. 
+  split. rewrite nextinstr_inv; auto with ppcgen.
+  apply Pregmap.gss.
+  intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto.
+  unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto.
+Qed.
+
+(** Indexed memory loads. *)
+
+Lemma loadind_aux_correct:
+  forall (base: ireg) ofs ty dst (rs: regset) m v,
+  Mem.loadv (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) = Some v ->
+  mreg_type dst = ty ->
+  base <> GPR0 ->
+  exec_instr ge fn (loadind_aux base ofs ty dst) rs m =
+    OK (nextinstr (rs#(preg_of dst) <- v)) m.
+Proof.
+  intros. unfold loadind_aux. unfold preg_of. rewrite H0. destruct ty.
+  simpl. unfold load1. rewrite gpr_or_zero_not_zero; auto.
+  unfold const_low. simpl in H. rewrite H. auto.
+  simpl. unfold load1. rewrite gpr_or_zero_not_zero; auto.
+  unfold const_low. simpl in H. rewrite H. auto.
+Qed.
+
+Lemma loadind_correct:
+  forall (base: ireg) ofs ty dst k (rs: regset) m v,
+  Mem.loadv (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) = Some v ->
+  mreg_type dst = ty ->
+  base <> GPR0 ->
+  exists rs',
+     exec_straight (loadind base ofs ty dst k) rs m k rs' m
+  /\ rs'#(preg_of dst) = v
+  /\ forall r, r <> PC -> r <> GPR12 -> r <> preg_of dst -> rs'#r = rs#r.
+Proof.
+  intros. unfold loadind.
+  assert (preg_of dst <> PC).
+    unfold preg_of. case (mreg_type dst); discriminate.
+  (* short offset *)
+  case (Int.eq (high_s ofs) Int.zero).
+  exists (nextinstr (rs#(preg_of dst) <- v)).
+  split. apply exec_straight_one. apply loadind_aux_correct; auto. 
+  unfold nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso. auto. auto.
+  split. rewrite nextinstr_inv; auto. apply Pregmap.gss.
+  intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto.
+  (* long offset *)
+  pose (rs1 := nextinstr (rs#GPR12 <- (Val.add rs#base (Vint (Int.shl (high_s ofs) (Int.repr 16)))))).
+  exists (nextinstr (rs1#(preg_of dst) <- v)).
+  split. apply exec_straight_two with rs1 m.
+  simpl. rewrite gpr_or_zero_not_zero; auto. 
+  apply loadind_aux_correct. 
+  unfold rs1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. 
+  rewrite Val.add_assoc. simpl. rewrite low_high_s. assumption.
+  auto. discriminate. reflexivity. 
+  unfold nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso. auto. auto.
+  split. rewrite nextinstr_inv; auto. apply Pregmap.gss.
+  intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto.
+  unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto.
+Qed.
+
+(** Indexed memory stores. *)
+
+Lemma storeind_aux_correct:
+  forall (base: ireg) ofs ty src (rs: regset) m m',
+  Mem.storev (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) (rs#(preg_of src)) = Some m' ->
+  mreg_type src = ty ->
+  base <> GPR0 ->
+  exec_instr ge fn (storeind_aux src base ofs ty) rs m =
+    OK (nextinstr rs) m'.
+Proof.
+  intros. unfold storeind_aux. unfold preg_of in H. rewrite H0 in H. destruct ty.
+  simpl. unfold store1. rewrite gpr_or_zero_not_zero; auto.
+  unfold const_low. simpl in H. rewrite H. auto.
+  simpl. unfold store1. rewrite gpr_or_zero_not_zero; auto.
+  unfold const_low. simpl in H. rewrite H. auto.
+Qed.
+
+Lemma storeind_correct:
+  forall (base: ireg) ofs ty src k (rs: regset) m m',
+  Mem.storev (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) (rs#(preg_of src)) = Some m' ->
+  mreg_type src = ty ->
+  base <> GPR0 ->
+  exists rs',
+     exec_straight (storeind src base ofs ty k) rs m k rs' m'
+  /\ forall r, r <> PC -> r <> GPR12 -> rs'#r = rs#r.
+Proof.
+  intros. unfold storeind.
+  (* short offset *)
+  case (Int.eq (high_s ofs) Int.zero).
+  exists (nextinstr rs).
+  split. apply exec_straight_one. apply storeind_aux_correct; auto. 
+  reflexivity. 
+  intros. rewrite nextinstr_inv; auto. 
+  (* long offset *)
+  pose (rs1 := nextinstr (rs#GPR12 <- (Val.add rs#base (Vint (Int.shl (high_s ofs) (Int.repr 16)))))).
+  exists (nextinstr rs1).
+  split. apply exec_straight_two with rs1 m.
+  simpl. rewrite gpr_or_zero_not_zero; auto. 
+  apply storeind_aux_correct; auto with ppcgen.
+  unfold rs1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. 
+  rewrite nextinstr_inv; auto with ppcgen.
+  rewrite Pregmap.gso; auto with ppcgen.
+  rewrite Val.add_assoc. simpl. rewrite low_high_s. assumption.
+  reflexivity. reflexivity.
+  intros. rewrite nextinstr_inv; auto.
+  unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto.
+Qed.
+
+(** Float comparisons. *)
+
+Lemma floatcomp_correct:
+  forall cmp (r1 r2: freg) k rs m,
+  exists rs',
+     exec_straight (floatcomp cmp r1 r2 k) rs m k rs' m
+  /\ rs'#(reg_of_crbit (fst (crbit_for_fcmp cmp))) = 
+       (if snd (crbit_for_fcmp cmp)
+        then Val.cmpf cmp rs#r1 rs#r2
+        else Val.notbool (Val.cmpf cmp rs#r1 rs#r2))
+  /\ forall r', 
+       r' <> PC -> r' <> CR0_0 -> r' <> CR0_1 ->
+       r' <> CR0_2 -> r' <> CR0_3 -> rs'#r' = rs#r'.
+Proof.
+  intros. 
+  generalize (compare_float_spec rs rs#r1 rs#r2).
+  intros [A [B [C D]]].
+  set (rs1 := nextinstr (compare_float rs rs#r1 rs#r2)) in *.
+  assert ((cmp = Ceq \/ cmp = Cne \/ cmp = Clt \/ cmp = Cgt)
+          \/ (cmp = Cle \/ cmp = Cge)).
+    case cmp; tauto.
+  unfold floatcomp.  elim H; intro; clear H.
+  exists rs1.
+  split. generalize H0; intros [EQ|[EQ|[EQ|EQ]]]; subst cmp;
+  apply exec_straight_one; reflexivity.
+  split. 
+  generalize H0; intros [EQ|[EQ|[EQ|EQ]]]; subst cmp; simpl; auto. 
+  rewrite Val.negate_cmpf_eq. auto.
+  auto.
+  (* two instrs *)
+  exists (nextinstr (rs1#CR0_3 <- (Val.cmpf cmp rs#r1 rs#r2))).
+  split. elim H0; intro; subst cmp.
+  apply exec_straight_two with rs1 m.
+  reflexivity. simpl. 
+  rewrite C; rewrite A. rewrite Val.or_commut. rewrite <- Val.cmpf_le.
+  reflexivity. reflexivity. reflexivity.
+  apply exec_straight_two with rs1 m.
+  reflexivity. simpl. 
+  rewrite C; rewrite B. rewrite Val.or_commut. rewrite <- Val.cmpf_ge.
+  reflexivity. reflexivity. reflexivity.
+  split. elim H0; intro; subst cmp; simpl.
+  reflexivity.
+  reflexivity.
+  intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto.
+Qed.
+
+Ltac TypeInv :=
+  match goal with
+  | H: (List.map ?f ?x = nil) |- _ =>
+      destruct x; [clear H | simpl in H; discriminate]
+  | H: (List.map ?f ?x = ?hd :: ?tl) |- _ =>
+      destruct x; simpl in H;
+      [ discriminate |
+        injection H; clear H; let T := fresh "T" in (
+          intros H T; TypeInv) ]
+  | _ => idtac
+  end.
+
+(** Translation of conditions. *)
+
+Lemma transl_cond_correct_aux:
+  forall cond args k ms sp rs m,
+  map mreg_type args = type_of_condition cond ->
+  agree ms sp rs ->
+  exists rs',
+     exec_straight (transl_cond cond args k) rs m k rs' m
+  /\ rs'#(reg_of_crbit (fst (crbit_for_cond cond))) = 
+       (if snd (crbit_for_cond cond)
+        then eval_condition_total cond (map ms args)
+        else Val.notbool (eval_condition_total cond (map ms args)))
+  /\ agree ms sp rs'.
+Proof.
+  intros.  destruct cond; simpl in H; TypeInv.
+  (* Ccomp *)
+  simpl. 
+  generalize (compare_sint_spec rs ms#m0 ms#m1).
+  intros [A [B [C D]]].
+  exists (nextinstr (compare_sint rs ms#m0 ms#m1)).
+  split. apply exec_straight_one. simpl. 
+  repeat (rewrite <- (ireg_val ms sp rs); auto).
+  reflexivity.
+  split. 
+  case c; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto.
+  apply agree_exten_2 with rs; auto.
+  (* Ccompu *)
+  simpl. 
+  generalize (compare_uint_spec rs ms#m0 ms#m1).
+  intros [A [B [C D]]].
+  exists (nextinstr (compare_uint rs ms#m0 ms#m1)).
+  split. apply exec_straight_one. simpl. 
+  repeat (rewrite <- (ireg_val ms sp rs); auto).
+  reflexivity.
+  split. 
+  case c; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto.
+  apply agree_exten_2 with rs; auto.
+  (* Ccompimm *)
+  simpl.
+  case (Int.eq (high_s i) Int.zero).
+  generalize (compare_sint_spec rs ms#m0 (Vint i)).
+  intros [A [B [C D]]].
+  exists (nextinstr (compare_sint rs ms#m0 (Vint i))).
+  split. apply exec_straight_one. simpl. 
+  repeat (rewrite <- (ireg_val ms sp rs); auto).
+  reflexivity.
+  split. 
+  case c; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto.
+  apply agree_exten_2 with rs; auto.
+  generalize (loadimm_correct GPR12 i (Pcmpw (ireg_of m0) GPR12 :: k) rs m).
+  intros [rs1 [EX1 [RES1 OTH1]]].
+  assert (agree ms sp rs1). apply agree_exten_2 with rs; auto.
+  generalize (compare_sint_spec rs1 ms#m0 (Vint i)).
+  intros [A [B [C D]]].
+  exists (nextinstr (compare_sint rs1 ms#m0 (Vint i))).
+  split. eapply exec_straight_trans. eexact EX1.
+  apply exec_straight_one. simpl. 
+  repeat (rewrite <- (ireg_val ms sp rs1); auto). rewrite RES1.
+  reflexivity. reflexivity.
+  split. 
+  case c; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto.
+  apply agree_exten_2 with rs1; auto.
+  (* Ccompuimm *)
+  simpl.
+  case (Int.eq (high_u i) Int.zero).
+  generalize (compare_uint_spec rs ms#m0 (Vint i)).
+  intros [A [B [C D]]].
+  exists (nextinstr (compare_uint rs ms#m0 (Vint i))).
+  split. apply exec_straight_one. simpl. 
+  repeat (rewrite <- (ireg_val ms sp rs); auto).
+  reflexivity.
+  split. 
+  case c; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto.
+  apply agree_exten_2 with rs; auto.
+  generalize (loadimm_correct GPR12 i (Pcmplw (ireg_of m0) GPR12 :: k) rs m).
+  intros [rs1 [EX1 [RES1 OTH1]]].
+  assert (agree ms sp rs1). apply agree_exten_2 with rs; auto.
+  generalize (compare_uint_spec rs1 ms#m0 (Vint i)).
+  intros [A [B [C D]]].
+  exists (nextinstr (compare_uint rs1 ms#m0 (Vint i))).
+  split. eapply exec_straight_trans. eexact EX1.
+  apply exec_straight_one. simpl. 
+  repeat (rewrite <- (ireg_val ms sp rs1); auto). rewrite RES1.
+  reflexivity. reflexivity.
+  split. 
+  case c; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto.
+  apply agree_exten_2 with rs1; auto.
+  (* Ccompf *)
+  simpl.
+  generalize (floatcomp_correct c (freg_of m0) (freg_of m1) k rs m).
+  intros [rs' [EX [RES OTH]]].
+  exists rs'. split. auto. 
+  split. rewrite RES. repeat (rewrite <- (freg_val ms sp rs); auto). 
+  apply agree_exten_2 with rs; auto.
+  (* Cnotcompf *)
+  simpl. 
+  generalize (floatcomp_correct c (freg_of m0) (freg_of m1) k rs m).
+  intros [rs' [EX [RES OTH]]].
+  exists rs'. split. auto. 
+  split. rewrite RES. repeat (rewrite <- (freg_val ms sp rs); auto).
+  assert (forall v1 v2, Val.notbool (Val.notbool (Val.cmpf c v1 v2)) = Val.cmpf c v1 v2).
+    intros v1 v2; unfold Val.cmpf; destruct v1; destruct v2; auto. 
+    apply Val.notbool_idem2.
+  rewrite H.
+  generalize RES. case (snd (crbit_for_fcmp c)); simpl; auto.
+  apply agree_exten_2 with rs; auto.
+  (* Cmaskzero *)
+  simpl.
+  generalize (andimm_correct GPR12 (ireg_of m0) i k rs m (ireg_of_not_GPR12 m0)).
+  intros [rs' [A [B [C D]]]].
+  exists rs'. split. assumption. 
+  split. rewrite C. rewrite <- (ireg_val ms sp rs); auto.
+  apply agree_exten_2 with rs; auto.
+  (* Cmasknotzero *)
+  simpl.
+  generalize (andimm_correct GPR12 (ireg_of m0) i k rs m (ireg_of_not_GPR12 m0)).
+  intros [rs' [A [B [C D]]]].
+  exists rs'. split. assumption. 
+  split. rewrite C. rewrite <- (ireg_val ms sp rs); auto.
+  rewrite Val.notbool_idem3. reflexivity. 
+  apply agree_exten_2 with rs; auto.
+Qed.
+
+Lemma transl_cond_correct:
+  forall cond args k ms sp rs m b,
+  map mreg_type args = type_of_condition cond ->
+  agree ms sp rs ->
+  eval_condition cond (map ms args) m = Some b ->
+  exists rs',
+     exec_straight (transl_cond cond args k) rs m k rs' m
+  /\ rs'#(reg_of_crbit (fst (crbit_for_cond cond))) = 
+       (if snd (crbit_for_cond cond)
+        then Val.of_bool b
+        else Val.notbool (Val.of_bool b))
+  /\ agree ms sp rs'.
+Proof.
+  intros. rewrite <- (eval_condition_weaken _ _ _ H1). 
+  apply transl_cond_correct_aux; auto.
+Qed.
+
+(** Translation of arithmetic operations. *)
+
+Ltac TranslOpSimpl :=
+  match goal with
+  | |- exists rs' : regset,
+         exec_straight ?c ?rs ?m ?k rs' ?m /\
+         agree (Regmap.set ?res ?v ?ms) ?sp rs'  =>
+    (exists (nextinstr (rs#(ireg_of res) <- v));
+     split; 
+     [ apply exec_straight_one;
+       [ repeat (rewrite (ireg_val ms sp rs); auto); reflexivity
+       | reflexivity ]
+     | auto with ppcgen ])
+  ||
+    (exists (nextinstr (rs#(freg_of res) <- v));
+     split; 
+     [ apply exec_straight_one;
+       [ repeat (rewrite (freg_val ms sp rs); auto); reflexivity
+       | reflexivity ]
+     | auto with ppcgen ])
+  end.
+
+Lemma transl_op_correct:
+  forall op args res k ms sp rs m v,
+  wt_instr (Mop op args res) ->
+  agree ms sp rs ->
+  eval_operation ge sp op (map ms args) m = Some v ->
+  exists rs',
+     exec_straight (transl_op op args res k) rs m k rs' m
+  /\ agree (Regmap.set res v ms) sp rs'.
+Proof.
+  intros. rewrite <- (eval_operation_weaken _ _ _ _ _ H1). clear H1; clear v.
+  inversion H.
+  (* Omove *)
+  simpl. exists (nextinstr (rs#(preg_of res) <- (ms r1))).
+  split. caseEq (mreg_type r1); intro.
+  apply exec_straight_one. simpl. rewrite (ireg_val ms sp rs); auto.
+  simpl. unfold preg_of. rewrite <- H2. rewrite H5. reflexivity.
+  auto with ppcgen.
+  apply exec_straight_one. simpl. rewrite (freg_val ms sp rs); auto.
+  simpl. unfold preg_of. rewrite <- H2. rewrite H5. reflexivity.
+  auto with ppcgen.
+  auto with ppcgen.
+  (* Other instructions *)
+  clear H1; clear H2; clear H4.
+  destruct op; simpl in H5; injection H5; clear H5; intros;
+  TypeInv; simpl; try (TranslOpSimpl).
+  (* Omove again *)
+  congruence.
+  (* Ointconst *)
+  generalize (loadimm_correct (ireg_of res) i k rs m).
+  intros [rs' [A [B C]]]. 
+  exists rs'. split. auto. 
+  apply agree_set_mireg_exten with rs; auto. 
+  (* Ofloatconst *)
+  exists (nextinstr (rs#(freg_of res) <- (Vfloat f) #GPR12 <- Vundef)).
+  split. apply exec_straight_one. reflexivity. reflexivity.
+  auto with ppcgen.
+  (* Oaddrsymbol *)
+  change (find_symbol_offset ge i i0) with (symbol_offset ge i i0).
+  set (v := symbol_offset ge i i0).
+  pose (rs1 := nextinstr (rs#GPR12 <- (high_half v))).
+  exists (nextinstr (rs1#(ireg_of res) <- v)).
+  split. apply exec_straight_two with rs1 m.
+  unfold exec_instr. rewrite gpr_or_zero_zero.
+  unfold const_high. rewrite Val.add_commut. 
+  rewrite high_half_zero. reflexivity. 
+  simpl. rewrite gpr_or_zero_not_zero. 2: congruence. 
+  unfold rs1 at 1. rewrite nextinstr_inv; auto with ppcgen.
+  rewrite Pregmap.gss. 
+  fold v. rewrite Val.add_commut. unfold v. rewrite low_high_half.
+  reflexivity. reflexivity. reflexivity. 
+  unfold rs1. apply agree_nextinstr. apply agree_set_mireg; auto.
+  apply agree_set_mreg. apply agree_nextinstr.
+  apply agree_set_other. auto. simpl. tauto.
+  (* Oaddrstack *)
+  assert (GPR1 <> GPR12). discriminate.
+  generalize (addimm_correct (ireg_of res) GPR1 i k rs m H2). 
+  intros [rs' [EX [RES OTH]]].
+  exists rs'. split. auto. 
+  apply agree_set_mireg_exten with rs; auto.
+  rewrite (sp_val ms sp rs). auto. auto. 
+  (* Ocast8unsigned *)
+  exists (nextinstr (rs#(ireg_of res) <- (Val.rolm (ms m0) Int.zero (Int.repr 255)))).
+  split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs)); auto. reflexivity.
+  replace (Val.zero_ext 8 (ms m0))
+      with (Val.rolm (ms m0) Int.zero (Int.repr 255)).
+  auto with ppcgen. 
+  unfold Val.rolm, Val.zero_ext. destruct (ms m0); auto. 
+  rewrite Int.rolm_zero. rewrite Int.zero_ext_and. auto. compute; auto.
+  (* Ocast16unsigned *)
+  exists (nextinstr (rs#(ireg_of res) <- (Val.rolm (ms m0) Int.zero (Int.repr 65535)))).
+  split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs)); auto. reflexivity.
+  replace (Val.zero_ext 16 (ms m0))
+      with (Val.rolm (ms m0) Int.zero (Int.repr 65535)).
+  auto with ppcgen. 
+  unfold Val.rolm, Val.zero_ext. destruct (ms m0); auto. 
+  rewrite Int.rolm_zero. rewrite Int.zero_ext_and. auto. compute; auto.
+  (* Oaddimm *)
+  generalize (addimm_correct (ireg_of res) (ireg_of m0) i k rs m
+                            (ireg_of_not_GPR12 m0)).
+  intros [rs' [A [B C]]]. 
+  exists rs'. split. auto.
+  apply agree_set_mireg_exten with rs; auto.
+  rewrite (ireg_val ms sp rs); auto. 
+  (* Osub *)
+  exists (nextinstr (rs#(ireg_of res) <- (Val.sub (ms m0) (ms m1)) #CARRY <- Vundef)).
+  split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs); auto).
+  simpl. reflexivity. auto with ppcgen.
+  (* Osubimm *)
+  case (Int.eq (high_s i) Int.zero).
+  exists (nextinstr (rs#(ireg_of res) <- (Val.sub (Vint i) (ms m0)) #CARRY <- Vundef)).
+  split. apply exec_straight_one. rewrite (ireg_val ms sp rs); auto.
+  reflexivity. simpl. auto with ppcgen.
+  generalize (loadimm_correct GPR12 i (Psubfc (ireg_of res) (ireg_of m0) GPR12 :: k) rs m).
+  intros [rs1 [EX [RES OTH]]].
+  assert (agree ms sp rs1). apply agree_exten_2 with rs; auto.
+  exists (nextinstr (rs1#(ireg_of res) <- (Val.sub (Vint i) (ms m0)) #CARRY <- Vundef)).
+  split. eapply exec_straight_trans. eexact EX. 
+  apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs); auto).
+  simpl. rewrite RES. rewrite OTH. reflexivity. 
+  generalize (ireg_of_not_GPR12 m0); congruence.
+  discriminate.
+  reflexivity. simpl; auto with ppcgen.
+  (* Omulimm *)
+  case (Int.eq (high_s i) Int.zero).
+  exists (nextinstr (rs#(ireg_of res) <- (Val.mul (ms m0) (Vint i)))).
+  split. apply exec_straight_one. rewrite (ireg_val ms sp rs); auto.
+  reflexivity. auto with ppcgen.
+  generalize (loadimm_correct GPR12 i (Pmullw (ireg_of res) (ireg_of m0) GPR12 :: k) rs m).
+  intros [rs1 [EX [RES OTH]]].
+  assert (agree ms sp rs1). apply agree_exten_2 with rs; auto.
+  exists (nextinstr (rs1#(ireg_of res) <- (Val.mul (ms m0) (Vint i)))).
+  split. eapply exec_straight_trans. eexact EX. 
+  apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs); auto).
+  simpl. rewrite RES. rewrite OTH. reflexivity. 
+  generalize (ireg_of_not_GPR12 m0); congruence.
+  discriminate.
+  reflexivity. simpl; auto with ppcgen.
+  (* Oand *)
+  pose (v := Val.and (ms m0) (ms m1)).
+  pose (rs1 := rs#(ireg_of res) <- v).
+  generalize (compare_sint_spec rs1 v Vzero).
+  intros [A [B [C D]]].
+  exists (nextinstr (compare_sint rs1 v Vzero)).
+  split. apply exec_straight_one. 
+  unfold rs1, v. repeat (rewrite (ireg_val ms sp rs); auto). 
+  reflexivity.  
+  apply agree_exten_2 with rs1. unfold rs1, v; auto with ppcgen.
+  auto.
+  (* Oandimm *)
+  generalize (andimm_correct (ireg_of res) (ireg_of m0) i k rs m
+                             (ireg_of_not_GPR12 m0)).
+  intros [rs' [A [B [C D]]]]. 
+  exists rs'. split. auto. apply agree_set_mireg_exten with rs; auto.
+  rewrite (ireg_val ms sp rs); auto.
+  (* Oorimm *)
+  generalize (orimm_correct (ireg_of res) (ireg_of m0) i k rs m).
+  intros [rs' [A [B C]]]. 
+  exists rs'. split. auto. apply agree_set_mireg_exten with rs; auto.
+  rewrite (ireg_val ms sp rs); auto.
+  (* Oxorimm *)
+  generalize (xorimm_correct (ireg_of res) (ireg_of m0) i k rs m).
+  intros [rs' [A [B C]]]. 
+  exists rs'. split. auto. apply agree_set_mireg_exten with rs; auto.
+  rewrite (ireg_val ms sp rs); auto.
+  (* Oshr *)
+  exists (nextinstr (rs#(ireg_of res) <- (Val.shr (ms m0) (ms m1)) #CARRY <- (Val.shr_carry (ms m0) (ms m1)))).
+  split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs); auto).
+  reflexivity. auto with ppcgen.
+  (* Oshrimm *)
+  exists (nextinstr (rs#(ireg_of res) <- (Val.shr (ms m0) (Vint i)) #CARRY <- (Val.shr_carry (ms m0) (Vint i)))).
+  split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs); auto).
+  reflexivity. auto with ppcgen.
+  (* Oxhrximm *)
+  pose (rs1 := nextinstr (rs#(ireg_of res) <- (Val.shr (ms m0) (Vint i)) #CARRY <- (Val.shr_carry (ms m0) (Vint i)))).
+  exists (nextinstr (rs1#(ireg_of res) <- (Val.shrx (ms m0) (Vint i)))).
+  split. apply exec_straight_two with rs1 m.
+  unfold rs1; rewrite (ireg_val ms sp rs); auto.
+  simpl; unfold rs1; repeat rewrite <- (ireg_val ms sp rs); auto.
+  repeat (rewrite nextinstr_inv; try discriminate).
+  repeat rewrite Pregmap.gss. decEq. decEq. 
+  apply (f_equal3 (@Pregmap.set val)); auto.
+  rewrite Pregmap.gso. rewrite Pregmap.gss. apply Val.shrx_carry.
+  discriminate. reflexivity. reflexivity.
+  apply agree_exten_2 with (rs#(ireg_of res) <- (Val.shrx (ms m0) (Vint i))).
+  auto with ppcgen. 
+  intros. rewrite nextinstr_inv; auto. 
+  case (preg_eq (ireg_of res) r); intro.
+  subst r. repeat rewrite Pregmap.gss. auto.
+  repeat rewrite Pregmap.gso; auto.
+  unfold rs1. rewrite nextinstr_inv; auto.
+  repeat rewrite Pregmap.gso; auto.
+  (* Ointoffloat *)
+  exists (nextinstr (rs#(ireg_of res) <- (Val.intoffloat (ms m0)) #FPR13 <- Vundef)).
+  split. apply exec_straight_one. 
+  repeat (rewrite (freg_val ms sp rs); auto).
+  reflexivity. auto with ppcgen.
+  (* Ointuoffloat *)
+  exists (nextinstr (rs#(ireg_of res) <- (Val.intuoffloat (ms m0)) #FPR13 <- Vundef)).
+  split. apply exec_straight_one. 
+  repeat (rewrite (freg_val ms sp rs); auto).
+  reflexivity. auto with ppcgen.
+  (* Ofloatofint *)
+  exists (nextinstr (rs#(freg_of res) <- (Val.floatofint (ms m0)) #GPR12 <- Vundef #FPR13 <- Vundef)).
+  split. apply exec_straight_one. 
+  repeat (rewrite (ireg_val ms sp rs); auto).
+  reflexivity. auto 10 with ppcgen.
+  (* Ofloatofintu *)
+  exists (nextinstr (rs#(freg_of res) <- (Val.floatofintu (ms m0)) #GPR12 <- Vundef #FPR13 <- Vundef)).
+  split. apply exec_straight_one. 
+  repeat (rewrite (ireg_val ms sp rs); auto).
+  reflexivity. auto 10 with ppcgen.
+  (* Ocmp *)
+  set (bit := fst (crbit_for_cond c)).
+  set (isset := snd (crbit_for_cond c)).
+  set (k1 :=
+        Pmfcrbit (ireg_of res) bit ::
+        (if isset
+         then k
+         else Pxori (ireg_of res) (ireg_of res) (Cint Int.one) :: k)).
+  generalize (transl_cond_correct_aux c args k1 ms sp rs m H2 H0).
+  fold bit; fold isset. 
+  intros [rs1 [EX1 [RES1 AG1]]].
+  set (rs2 := nextinstr (rs1#(ireg_of res) <- (rs1#(reg_of_crbit bit)))).
+  destruct isset.
+  exists rs2.
+  split. apply exec_straight_trans with k1 rs1 m. assumption.
+  unfold k1. apply exec_straight_one. 
+  reflexivity. reflexivity. 
+  unfold rs2. rewrite RES1. auto with ppcgen. 
+  exists (nextinstr (rs2#(ireg_of res) <- (eval_condition_total c ms##args))).
+  split. apply exec_straight_trans with k1 rs1 m. assumption.
+  unfold k1. apply exec_straight_two with rs2 m.
+  reflexivity. simpl. 
+  replace (Val.xor (rs2 (ireg_of res)) (Vint Int.one))
+     with (eval_condition_total c ms##args).
+  reflexivity.
+  unfold rs2. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. 
+  rewrite RES1. apply Val.notbool_xor. apply eval_condition_total_is_bool.
+  reflexivity. reflexivity. 
+  unfold rs2. auto with ppcgen. 
+Qed.
+
+Lemma transl_load_store_correct:
+  forall (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction)
+    addr args k ms sp rs m ms' m',
+  (forall cst (r1: ireg) (rs1: regset) k,
+    eval_addressing_total ge sp addr (map ms args) = Val.add rs1#r1 (const_low ge cst) ->
+    agree ms sp rs1 ->
+    r1 <> GPR0 ->
+    exists rs',
+    exec_straight (mk1 cst r1 :: k) rs1 m k rs' m' /\
+    agree ms' sp rs') ->
+  (forall (r1 r2: ireg) (rs1: regset) k,
+    eval_addressing_total ge sp addr (map ms args) = Val.add rs1#r1 rs1#r2 ->
+    agree ms sp rs1 ->
+    exists rs',
+    exec_straight (mk2 r1 r2 :: k) rs1 m k rs' m' /\
+    agree ms' sp rs') ->
+  agree ms sp rs ->
+  map mreg_type args = type_of_addressing addr ->
+  exists rs',
+    exec_straight (transl_load_store mk1 mk2 addr args k) rs m
+                        k rs' m'
+  /\ agree ms' sp rs'.
+Proof.
+  intros. destruct addr; simpl in H2; TypeInv; simpl.
+  (* Aindexed *)
+  case (ireg_eq (ireg_of t) GPR0); intro.
+  (* Aindexed from GPR0 *)
+  set (rs1 := nextinstr (rs#GPR12 <- (ms t))).
+  set (rs2 := nextinstr (rs1#GPR12 <- (Val.add (ms t) (Vint (Int.shl (high_s i) (Int.repr 16)))))).
+  assert (ADDR: eval_addressing_total ge sp (Aindexed i) ms##(t :: nil) =
+                Val.add rs2#GPR12 (const_low ge (Cint (low_s i)))).
+    simpl. unfold rs2. rewrite nextinstr_inv. rewrite Pregmap.gss.
+    rewrite Val.add_assoc. simpl. rewrite low_high_s. auto.
+    discriminate.
+  assert (AG: agree ms sp rs2). unfold rs2, rs1; auto 6 with ppcgen.
+  assert (NOT0: GPR12 <> GPR0). discriminate.
+  generalize (H _ _ _ k ADDR AG NOT0).
+  intros [rs' [EX' AG']].
+  exists rs'. split.
+  apply exec_straight_trans with (mk1 (Cint (low_s i)) GPR12 :: k) rs2 m.
+  apply exec_straight_two with rs1 m.
+  unfold rs1. rewrite (ireg_val ms sp rs); auto.
+  unfold rs2. replace (ms t) with (rs1#GPR12). auto.
+  unfold rs1. rewrite nextinstr_inv. apply Pregmap.gss. discriminate.
+  reflexivity. reflexivity.  
+  assumption. assumption.
+  (* Aindexed short *)
+  case (Int.eq (high_s i) Int.zero).
+  assert (ADDR: eval_addressing_total ge sp (Aindexed i) ms##(t :: nil) =
+                Val.add rs#(ireg_of t) (const_low ge (Cint i))).
+    simpl. rewrite (ireg_val ms sp rs); auto.
+  generalize (H _ _ _ k ADDR H1 n). intros [rs' [EX' AG']].
+  exists rs'. split. auto. auto.
+  (* Aindexed long *)
+  set (rs1 := nextinstr (rs#GPR12 <- (Val.add (ms t) (Vint (Int.shl (high_s i) (Int.repr 16)))))).
+  assert (ADDR: eval_addressing_total ge sp (Aindexed i) ms##(t :: nil) =
+                Val.add rs1#GPR12 (const_low ge (Cint (low_s i)))).
+    simpl. unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss.
+    rewrite Val.add_assoc. simpl. rewrite low_high_s. auto.
+    discriminate.
+  assert (AG: agree ms sp rs1). unfold rs1; auto with ppcgen.
+  assert (NOT0: GPR12 <> GPR0). discriminate.
+  generalize (H _ _ _ k ADDR AG NOT0). intros [rs' [EX' AG']].
+  exists rs'. split. apply exec_straight_step with rs1 m.
+  simpl. rewrite gpr_or_zero_not_zero; auto. 
+  rewrite <- (ireg_val ms sp rs); auto. reflexivity.
+  assumption. assumption.
+  (* Aindexed2 *)
+  apply H0. 
+  simpl. repeat (rewrite (ireg_val ms sp rs); auto). auto.
+  (* Aglobal *)
+  set (rs1 := nextinstr (rs#GPR12 <- (const_high ge (Csymbol_high i i0)))).
+  assert (ADDR: eval_addressing_total ge sp (Aglobal i i0) ms##nil =
+                Val.add rs1#GPR12 (const_low ge (Csymbol_low i i0))).
+    simpl. unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss.
+    unfold const_high, const_low. 
+    set (v := symbol_offset ge i i0).
+    symmetry. rewrite Val.add_commut. unfold v. apply low_high_half. 
+    discriminate.
+  assert (AG: agree ms sp rs1). unfold rs1; auto with ppcgen.
+  assert (NOT0: GPR12 <> GPR0). discriminate.
+  generalize (H _ _ _ k ADDR AG NOT0). intros [rs' [EX' AG']].
+  exists rs'. split. apply exec_straight_step with rs1 m.
+  unfold exec_instr. rewrite gpr_or_zero_zero. 
+  rewrite Val.add_commut. unfold const_high. 
+  rewrite high_half_zero.
+  reflexivity. reflexivity.
+  assumption. assumption.
+  (* Abased *)
+  assert (COMMON:
+    forall (rs1: regset) r,
+    r <> GPR0 ->
+    ms t = rs1#r ->
+    agree ms sp rs1 ->
+    exists rs',
+      exec_straight
+        (Paddis GPR12 r (Csymbol_high i i0)
+         :: mk1 (Csymbol_low i i0) GPR12 :: k) rs1 m k rs' m'
+      /\ agree ms' sp rs').
+  intros. 
+  set (rs2 := nextinstr (rs1#GPR12 <- (Val.add (ms t) (const_high ge (Csymbol_high i i0))))).
+  assert (ADDR: eval_addressing_total ge sp (Abased i i0) ms##(t::nil) =
+                Val.add rs2#GPR12 (const_low ge (Csymbol_low i i0))).
+    simpl. unfold rs2. rewrite nextinstr_inv. rewrite Pregmap.gss.
+    unfold const_high. 
+    set (v := symbol_offset ge i i0).
+    rewrite Val.add_assoc. 
+    rewrite (Val.add_commut (high_half v)).
+    unfold v. rewrite low_high_half. apply Val.add_commut.
+    discriminate.
+  assert (AG: agree ms sp rs2). unfold rs2; auto with ppcgen.
+  assert (NOT0: GPR12 <> GPR0). discriminate.
+  generalize (H _ _ _ k ADDR AG NOT0). intros [rs' [EX' AG']].
+  exists rs'. split. apply exec_straight_step with rs2 m.
+  unfold exec_instr. rewrite gpr_or_zero_not_zero; auto.
+  rewrite <- H3. reflexivity. reflexivity. 
+  assumption. assumption.
+  case (ireg_eq (ireg_of t) GPR0); intro.
+  set (rs1 := nextinstr (rs#GPR12 <- (ms t))).
+  assert (R1: GPR12 <> GPR0). discriminate.
+  assert (R2: ms t = rs1 GPR12). 
+    unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss; auto.
+    discriminate.
+  assert (R3: agree ms sp rs1). unfold rs1; auto with ppcgen.
+  generalize (COMMON rs1 GPR12 R1 R2 R3). intros [rs' [EX' AG']].
+  exists rs'. split.
+  apply exec_straight_step with rs1 m.
+  unfold rs1. rewrite (ireg_val ms sp rs); auto. reflexivity.
+  assumption. assumption.
+  apply COMMON; auto. eapply ireg_val; eauto.
+  (* Ainstack *)
+  case (Int.eq (high_s i) Int.zero).
+  apply H. simpl. rewrite (sp_val ms sp rs); auto. auto.
+  discriminate.
+  set (rs1 := nextinstr (rs#GPR12 <- (Val.add sp (Vint (Int.shl (high_s i) (Int.repr 16)))))).
+  assert (ADDR: eval_addressing_total ge sp (Ainstack i) ms##nil =
+                Val.add rs1#GPR12 (const_low ge (Cint (low_s i)))).
+    simpl. unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss.
+    rewrite Val.add_assoc. decEq. simpl. rewrite low_high_s. auto.
+    discriminate.
+  assert (AG: agree ms sp rs1). unfold rs1; auto with ppcgen.
+  assert (NOT0: GPR12 <> GPR0). discriminate.
+  generalize (H _ _ _ k ADDR AG NOT0). intros [rs' [EX' AG']].
+  exists rs'. split. apply exec_straight_step with rs1 m.
+  simpl. rewrite gpr_or_zero_not_zero. 
+  unfold rs1. rewrite (sp_val ms sp rs). reflexivity.
+  auto. discriminate. reflexivity. assumption. assumption.
+Qed.
+
+(** Translation of memory loads. *)
+
+Lemma transl_load_correct:
+  forall (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction)
+    chunk addr args k ms sp rs m dst a v,
+  (forall cst (r1: ireg) (rs1: regset),
+    exec_instr ge fn (mk1 cst r1) rs1 m =
+    load1 ge chunk (preg_of dst) cst r1 rs1 m) ->
+  (forall (r1 r2: ireg) (rs1: regset),
+    exec_instr ge fn (mk2 r1 r2) rs1 m =
+    load2 chunk (preg_of dst) r1 r2 rs1 m) ->
+  agree ms sp rs ->
+  map mreg_type args = type_of_addressing addr ->
+  eval_addressing ge sp addr (map ms args) = Some a ->
+  Mem.loadv chunk m a = Some v ->
+  exists rs',
+    exec_straight (transl_load_store mk1 mk2 addr args k) rs m
+                        k rs' m
+  /\ agree (Regmap.set dst v ms) sp rs'.
+Proof.
+  intros. apply transl_load_store_correct with ms.
+  intros. exists (nextinstr (rs1#(preg_of dst) <- v)). 
+  split. apply exec_straight_one. rewrite H. 
+  unfold load1. rewrite gpr_or_zero_not_zero; auto. 
+  rewrite <- (eval_addressing_weaken _ _ _ _ H3) in H4.
+  rewrite H5 in H4. rewrite H4. auto.
+  auto with ppcgen. auto with ppcgen. 
+  intros. exists (nextinstr (rs1#(preg_of dst) <- v)). 
+  split. apply exec_straight_one. rewrite H0. 
+  unfold load2. 
+  rewrite <- (eval_addressing_weaken _ _ _ _ H3) in H4.
+  rewrite H5 in H4. rewrite H4. auto.
+  auto with ppcgen. auto with ppcgen. 
+  auto. auto.
+Qed.
+
+(** Translation of memory stores. *)
+
+Lemma transl_store_correct:
+  forall (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction)
+    chunk addr args k ms sp rs m src a m',
+  (forall cst (r1: ireg) (rs1: regset),
+    exec_instr ge fn (mk1 cst r1) rs1 m =
+    store1 ge chunk (preg_of src) cst r1 rs1 m) ->
+  (forall (r1 r2: ireg) (rs1: regset),
+    exec_instr ge fn (mk2 r1 r2) rs1 m =
+    store2 chunk (preg_of src) r1 r2 rs1 m) ->
+  agree ms sp rs ->
+  map mreg_type args = type_of_addressing addr ->
+  eval_addressing ge sp addr (map ms args) = Some a ->
+  Mem.storev chunk m a (ms src) = Some m' ->
+  exists rs',
+    exec_straight (transl_load_store mk1 mk2 addr args k) rs m
+                        k rs' m'
+  /\ agree ms sp rs'.
+Proof.
+  intros.   apply transl_load_store_correct with ms.
+  intros. exists (nextinstr rs1). 
+  split. apply exec_straight_one. rewrite H. 
+  unfold store1. rewrite gpr_or_zero_not_zero; auto. 
+  rewrite <- (eval_addressing_weaken _ _ _ _ H3) in H4.
+  rewrite H5 in H4. elim H6; intros. rewrite H9 in H4.
+  rewrite H4. auto.
+  auto with ppcgen. auto with ppcgen. 
+  intros. exists (nextinstr rs1).
+  split. apply exec_straight_one. rewrite H0. 
+  unfold store2. 
+  rewrite <- (eval_addressing_weaken _ _ _ _ H3) in H4.
+  rewrite H5 in H4. elim H6; intros. rewrite H8 in H4.
+  rewrite H4. auto.
+  auto with ppcgen. auto with ppcgen. 
+  auto. auto.
+Qed.
+
+(** Translation of allocations *)
+
+Lemma transl_alloc_correct:
+  forall ms sp rs sz m m' blk k,
+  agree ms sp rs ->
+  ms Conventions.loc_alloc_argument = Vint sz ->
+  Mem.alloc m 0 (Int.signed sz) = (m', blk) ->
+  let ms' := Regmap.set Conventions.loc_alloc_result (Vptr blk Int.zero) ms in
+  exists rs',
+    exec_straight (Pallocblock :: k) rs m k rs' m'
+  /\ agree ms' sp rs'.
+Proof.
+  intros. 
+  pose (rs' := nextinstr (rs#GPR3 <- (Vptr blk Int.zero) #LR <- (Val.add rs#PC Vone))).
+  exists rs'; split.
+  apply exec_straight_one. unfold exec_instr. 
+  generalize (preg_val _ _ _ Conventions.loc_alloc_argument H).
+  unfold preg_of; intro. simpl in H2. rewrite <- H2. rewrite H0.
+  rewrite H1. reflexivity.
+  reflexivity. 
+  unfold ms', rs'. apply agree_nextinstr. apply agree_set_other. 
+  change (IR GPR3) with (preg_of Conventions.loc_alloc_result).
+  apply agree_set_mreg. auto.
+  simpl. tauto.
+Qed.
+
+End STRAIGHTLINE.
+
diff --git a/powerpc/Asmgenretaddr.v b/powerpc/Asmgenretaddr.v
new file mode 100644
index 00000000..23bd186e
--- /dev/null
+++ b/powerpc/Asmgenretaddr.v
@@ -0,0 +1,188 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              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.     *)
+(*                                                                     *)
+(* *********************************************************************)
+
+(** Predictor for return addresses in generated PPC code.
+
+    The [return_address_offset] predicate defined here is used in the
+    concrete semantics for Mach (module [Machconcr]) to determine the
+    return addresses that are stored in activation records. *)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Mem.
+Require Import Globalenvs.
+Require Import Op.
+Require Import Locations.
+Require Import Mach.
+Require Import Asm.
+Require Import Asmgen.
+
+(** The ``code tail'' of an instruction list [c] is the list of instructions
+  starting at PC [pos]. *)
+
+Inductive code_tail: Z -> code -> code -> Prop :=
+  | code_tail_0: forall c,
+      code_tail 0 c c
+  | code_tail_S: forall pos i c1 c2,
+      code_tail pos c1 c2 ->
+      code_tail (pos + 1) (i :: c1) c2.
+
+Lemma code_tail_pos:
+  forall pos c1 c2, code_tail pos c1 c2 -> pos >= 0.
+Proof.
+  induction 1. omega. omega.
+Qed.
+
+(** 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 PPC code obtained by translating the
+  code of [f]. Graphically:
+<<
+     Mach function f    |--------- Mcall ---------|
+         Mach code c    |                |--------|
+                        |                 \        \
+                        |                  \        \
+                        |                   \        \
+     PPC code           |                    |--------|
+     PPC function       |--------------- Pbl ---------|
+
+                        <-------- ofs ------->
+>>
+*)
+
+Inductive return_address_offset: Mach.function -> Mach.code -> int -> Prop :=
+  | return_address_offset_intro:
+      forall c f ofs,
+      code_tail ofs (transl_function f) (transl_code f c) ->
+      return_address_offset f c (Int.repr ofs).
+
+(** We now show that such an offset always exists if the Mach code [c]
+  is a suffix of [f.(fn_code)].  This holds because the translation
+  from Mach to PPC is compositional: each Mach instruction becomes
+  zero, one or several PPC instructions, but the order of instructions
+  is preserved. *)
+
+Lemma is_tail_code_tail:
+  forall c1 c2, is_tail c1 c2 -> exists ofs, code_tail ofs c2 c1.
+Proof.
+  induction 1. exists 0; constructor.
+  destruct IHis_tail as [ofs CT]. exists (ofs + 1); constructor; auto.
+Qed.
+
+Hint Resolve is_tail_refl: ppcretaddr.
+
+Ltac IsTail :=
+  auto with ppcretaddr;
+  match goal with
+  | [ |- is_tail _ (_ :: _) ] => constructor; IsTail
+  | [ |- is_tail _ (match ?x with true => _ | false => _ end) ] => destruct x; IsTail
+  | [ |- is_tail _ (match ?x with left _ => _ | right _ => _ end) ] => destruct x; IsTail
+  | [ |- is_tail _ (match ?x with nil => _ | _ :: _ => _ end) ] => destruct x; IsTail
+  | [ |- is_tail _ (match ?x with Tint => _ | Tfloat => _ end) ] => destruct x; IsTail
+  | [ |- is_tail _ (?f _ _ _ _ _ _ ?k) ] => apply is_tail_trans with k; IsTail
+  | [ |- is_tail _ (?f _ _ _ _ _ ?k) ] => apply is_tail_trans with k; IsTail
+  | [ |- is_tail _ (?f _ _ _ _ ?k) ] => apply is_tail_trans with k; IsTail
+  | [ |- is_tail _ (?f _ _ _ ?k) ] => apply is_tail_trans with k; IsTail
+  | [ |- is_tail _ (?f _ _ ?k) ] => apply is_tail_trans with k; IsTail
+  | _ => idtac
+  end.
+
+Lemma loadimm_tail:
+  forall r n k, is_tail k (loadimm r n k).
+Proof. unfold loadimm; intros; IsTail. Qed.
+Hint Resolve loadimm_tail: ppcretaddr.
+
+Lemma addimm_tail:
+  forall r1 r2 n k, is_tail k (addimm r1 r2 n k).
+Proof. unfold addimm, addimm_1, addimm_2; intros; IsTail. Qed.
+Hint Resolve addimm_tail: ppcretaddr.
+
+Lemma andimm_tail:
+  forall r1 r2 n k, is_tail k (andimm r1 r2 n k).
+Proof. unfold andimm; intros; IsTail. Qed.
+Hint Resolve andimm_tail: ppcretaddr.
+
+Lemma orimm_tail:
+  forall r1 r2 n k, is_tail k (orimm r1 r2 n k).
+Proof. unfold orimm; intros; IsTail. Qed.
+Hint Resolve orimm_tail: ppcretaddr.
+
+Lemma xorimm_tail:
+  forall r1 r2 n k, is_tail k (xorimm r1 r2 n k).
+Proof. unfold xorimm; intros; IsTail. Qed.
+Hint Resolve xorimm_tail: ppcretaddr.
+
+Lemma loadind_tail:
+  forall base ofs ty dst k, is_tail k (loadind base ofs ty dst k).
+Proof. unfold loadind; intros; IsTail. Qed.
+Hint Resolve loadind_tail: ppcretaddr.
+
+Lemma storeind_tail:
+  forall src base ofs ty k, is_tail k (storeind src base ofs ty k).
+Proof. unfold storeind; intros; IsTail. Qed.
+Hint Resolve storeind_tail: ppcretaddr.
+
+Lemma floatcomp_tail:
+  forall cmp r1 r2 k, is_tail k (floatcomp cmp r1 r2 k).
+Proof. unfold floatcomp; intros; destruct cmp; IsTail. Qed.
+Hint Resolve floatcomp_tail: ppcretaddr.
+
+Lemma transl_cond_tail:
+  forall cond args k, is_tail k (transl_cond cond args k).
+Proof. unfold transl_cond; intros; destruct cond; IsTail. Qed.
+Hint Resolve transl_cond_tail: ppcretaddr.
+
+Lemma transl_op_tail:
+  forall op args r k, is_tail k (transl_op op args r k).
+Proof. unfold transl_op; intros; destruct op; IsTail. Qed.
+Hint Resolve transl_op_tail: ppcretaddr.
+
+Lemma transl_load_store_tail:
+  forall mk1 mk2 addr args k,
+  is_tail k (transl_load_store mk1 mk2 addr args k).
+Proof. unfold transl_load_store; intros; destruct addr; IsTail. Qed.
+Hint Resolve transl_load_store_tail: ppcretaddr.
+
+Lemma transl_instr_tail:
+  forall f i k, is_tail k (transl_instr f i k).
+Proof.
+  unfold transl_instr; intros; destruct i; IsTail.
+  destruct m; IsTail.
+  destruct m; IsTail.
+  destruct s0; IsTail.
+  destruct s0; IsTail.
+Qed.
+Hint Resolve transl_instr_tail: ppcretaddr.
+
+Lemma transl_code_tail: 
+  forall f c1 c2, is_tail c1 c2 -> is_tail (transl_code f c1) (transl_code f c2).
+Proof.
+  induction 1; simpl. constructor. eapply is_tail_trans; eauto with ppcretaddr.
+Qed.
+
+Lemma return_address_exists:
+  forall f c, is_tail c f.(fn_code) ->
+  exists ra, return_address_offset f c ra.
+Proof.
+  intros. assert (is_tail (transl_code f c) (transl_function f)).
+  unfold transl_function. IsTail. apply transl_code_tail; auto.
+  destruct (is_tail_code_tail _ _ H0) as [ofs A].
+  exists (Int.repr ofs). constructor. auto.
+Qed.
+
+ 
diff --git a/powerpc/Constprop.v b/powerpc/Constprop.v
new file mode 100644
index 00000000..75fb1486
--- /dev/null
+++ b/powerpc/Constprop.v
@@ -0,0 +1,1093 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              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.     *)
+(*                                                                     *)
+(* *********************************************************************)
+
+(** Constant propagation over RTL.  This is the first of the two
+  optimizations performed at RTL level.  It proceeds by a standard
+  dataflow analysis and the corresponding code transformation. *)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Globalenvs.
+Require Import Op.
+Require Import Registers.
+Require Import RTL.
+Require Import Lattice.
+Require Import Kildall.
+
+(** * Static analysis *)
+
+(** To each pseudo-register at each program point, the static analysis 
+  associates a compile-time approximation taken from the following set. *)
+
+Inductive approx : Set :=
+  | Novalue: approx      (** No value possible, code is unreachable. *)
+  | Unknown: approx      (** All values are possible,
+                             no compile-time information is available. *)
+  | I: int -> approx     (** A known integer value. *)
+  | F: float -> approx   (** A known floating-point value. *)
+  | S: ident -> int -> approx.
+                         (** The value is the address of the given global
+                             symbol plus the given integer offset. *)
+
+(** We equip this set of approximations with a semi-lattice structure.
+  The ordering is inclusion between the sets of values denoted by
+  the approximations. *)
+
+Module Approx <: SEMILATTICE_WITH_TOP.
+  Definition t := approx.
+  Definition eq (x y: t) := (x = y).
+  Definition eq_refl: forall x, eq x x := (@refl_equal t).
+  Definition eq_sym: forall x y, eq x y -> eq y x := (@sym_equal t).
+  Definition eq_trans: forall x y z, eq x y -> eq y z -> eq x z := (@trans_equal t).
+  Lemma eq_dec: forall (x y: t), {x=y} + {x<>y}.
+  Proof.
+    decide equality.
+    apply Int.eq_dec.
+    apply Float.eq_dec.
+    apply Int.eq_dec.
+    apply ident_eq.
+  Qed.
+  Definition beq (x y: t) := if eq_dec x y then true else false.
+  Lemma beq_correct: forall x y, beq x y = true -> x = y.
+  Proof.
+    unfold beq; intros.  destruct (eq_dec x y). auto. congruence.
+  Qed.
+  Definition ge (x y: t) : Prop :=
+    x = Unknown \/ y = Novalue \/ x = y.
+  Lemma ge_refl: forall x y, eq x y -> ge x y.
+  Proof.
+    unfold eq, ge; tauto.
+  Qed.
+  Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
+  Proof.
+    unfold ge; intuition congruence.
+  Qed.
+  Lemma ge_compat: forall x x' y y', eq x x' -> eq y y' -> ge x y -> ge x' y'.
+  Proof.
+    unfold eq, ge; intros; congruence.
+  Qed.
+  Definition bot := Novalue.
+  Definition top := Unknown.
+  Lemma ge_bot: forall x, ge x bot.
+  Proof.
+    unfold ge, bot; tauto.
+  Qed.
+  Lemma ge_top: forall x, ge top x.
+  Proof.
+    unfold ge, bot; tauto.
+  Qed.
+  Definition lub (x y: t) : t :=
+    if eq_dec x y then x else
+    match x, y with
+    | Novalue, _ => y
+    | _, Novalue => x
+    | _, _ => Unknown
+    end.
+  Lemma lub_commut: forall x y, eq (lub x y) (lub y x).
+  Proof.
+    unfold lub, eq; intros.
+    case (eq_dec x y); case (eq_dec y x); intros; try congruence.
+    destruct x; destruct y; auto.
+  Qed.
+  Lemma ge_lub_left: forall x y, ge (lub x y) x.
+  Proof.
+    unfold lub; intros.
+    case (eq_dec x y); intro.
+    apply ge_refl. apply eq_refl.
+    destruct x; destruct y; unfold ge; tauto.
+  Qed.
+End Approx.
+
+Module D := LPMap Approx.
+
+(** We now define the abstract interpretations of conditions and operators
+  over this set of approximations.  For instance, the abstract interpretation
+  of the operator [Oaddf] applied to two expressions [a] and [b] is
+  [F(Float.add f g)] if [a] and [b] have static approximations [Vfloat f]
+  and [Vfloat g] respectively, and [Unknown] otherwise.
+
+  The static approximations are defined by large pattern-matchings over
+  the approximations of the results.  We write these matchings in the
+  indirect style described in file [Cmconstr] to avoid excessive
+  duplication of cases in proofs. *)
+
+(*
+Definition eval_static_condition (cond: condition) (vl: list approx) :=
+  match cond, vl with
+  | Ccomp c, I n1 :: I n2 :: nil => Some(Int.cmp c n1 n2)
+  | Ccompu c, I n1 :: I n2 :: nil => Some(Int.cmpu c n1 n2)
+  | Ccompimm c n, I n1 :: nil => Some(Int.cmp c n1 n)
+  | Ccompuimm c n, I n1 :: nil => Some(Int.cmpu c n1 n)
+  | Ccompf c, F n1 :: F n2 :: nil => Some(Float.cmp c n1 n2)
+  | Cnotcompf c, F n1 :: F n2 :: nil => Some(negb(Float.cmp c n1 n2))
+  | Cmaskzero n, I n1 :: nil => Some(Int.eq (Int.and n1 n) Int.zero)
+  | Cmasknotzero n, n1::nil => Some(negb(Int.eq (Int.and n1 n) Int.zero))
+  | _, _ => None
+  end.
+*)
+
+Inductive eval_static_condition_cases: forall (cond: condition) (vl: list approx), Set :=
+  | eval_static_condition_case1:
+      forall c n1 n2,
+      eval_static_condition_cases (Ccomp c) (I n1 :: I n2 :: nil)
+  | eval_static_condition_case2:
+      forall c n1 n2,
+      eval_static_condition_cases (Ccompu c) (I n1 :: I n2 :: nil)
+  | eval_static_condition_case3:
+      forall c n n1,
+      eval_static_condition_cases (Ccompimm c n) (I n1 :: nil)
+  | eval_static_condition_case4:
+      forall c n n1,
+      eval_static_condition_cases (Ccompuimm c n) (I n1 :: nil)
+  | eval_static_condition_case5:
+      forall c n1 n2,
+      eval_static_condition_cases (Ccompf c) (F n1 :: F n2 :: nil)
+  | eval_static_condition_case6:
+      forall c n1 n2,
+      eval_static_condition_cases (Cnotcompf c) (F n1 :: F n2 :: nil)
+  | eval_static_condition_case7:
+      forall n n1,
+      eval_static_condition_cases (Cmaskzero n) (I n1 :: nil)
+  | eval_static_condition_case8:
+      forall n n1,
+      eval_static_condition_cases (Cmasknotzero n) (I n1 :: nil)
+  | eval_static_condition_default:
+      forall (cond: condition) (vl: list approx),
+      eval_static_condition_cases cond vl.
+
+Definition eval_static_condition_match (cond: condition) (vl: list approx) :=
+  match cond as z1, vl as z2 return eval_static_condition_cases z1 z2 with
+  | Ccomp c, I n1 :: I n2 :: nil =>
+      eval_static_condition_case1 c n1 n2
+  | Ccompu c, I n1 :: I n2 :: nil =>
+      eval_static_condition_case2 c n1 n2
+  | Ccompimm c n, I n1 :: nil =>
+      eval_static_condition_case3 c n n1
+  | Ccompuimm c n, I n1 :: nil =>
+      eval_static_condition_case4 c n n1
+  | Ccompf c, F n1 :: F n2 :: nil =>
+      eval_static_condition_case5 c n1 n2
+  | Cnotcompf c, F n1 :: F n2 :: nil =>
+      eval_static_condition_case6 c n1 n2
+  | Cmaskzero n, I n1 :: nil =>
+      eval_static_condition_case7 n n1
+  | Cmasknotzero n, I n1 :: nil =>
+      eval_static_condition_case8 n n1
+  | cond, vl =>
+      eval_static_condition_default cond vl
+  end.
+
+Definition eval_static_condition (cond: condition) (vl: list approx) :=
+  match eval_static_condition_match cond vl with
+  | eval_static_condition_case1 c n1 n2 =>
+      Some(Int.cmp c n1 n2)
+  | eval_static_condition_case2 c n1 n2 =>
+      Some(Int.cmpu c n1 n2)
+  | eval_static_condition_case3 c n n1 =>
+      Some(Int.cmp c n1 n)
+  | eval_static_condition_case4 c n n1 =>
+      Some(Int.cmpu c n1 n)
+  | eval_static_condition_case5 c n1 n2 =>
+      Some(Float.cmp c n1 n2)
+  | eval_static_condition_case6 c n1 n2 =>
+      Some(negb(Float.cmp c n1 n2))
+  | eval_static_condition_case7 n n1 =>
+      Some(Int.eq (Int.and n1 n) Int.zero)
+  | eval_static_condition_case8 n n1 =>
+      Some(negb(Int.eq (Int.and n1 n) Int.zero))
+  | eval_static_condition_default cond vl =>
+      None
+  end.
+
+(*
+Definition eval_static_operation (op: operation) (vl: list approx) :=
+  match op, vl with
+  | Omove, v1::nil => v1
+  | Ointconst n, nil => I n
+  | Ofloatconst n, nil => F n
+  | Oaddrsymbol s n, nil => S s n
+  | Ocast8signed, I n1 :: nil => I(Int.sign_ext 8 n)
+  | Ocast8unsigned, I n1 :: nil => I(Int.zero_ext 8 n)
+  | Ocast16signed, I n1 :: nil => I(Int.sign_ext 16 n)
+  | Ocast16unsigned, I n1 :: nil => I(Int.zero_ext 16 n)
+  | Oadd, I n1 :: I n2 :: nil => I(Int.add n1 n2)
+  | Oadd, S s1 n1 :: I n2 :: nil => S s1 (Int.add n1 n2)
+  | Oaddimm n, I n1 :: nil => I (Int.add n1 n)
+  | Oaddimm n, S s1 n1 :: nil => S s1 (Int.add n1 n)
+  | Osub, I n1 :: I n2 :: nil => I(Int.sub n1 n2)
+  | Osub, S s1 n1 :: I n2 :: nil => S s1 (Int.sub n1 n2)
+  | Osubimm n, I n1 :: nil => I (Int.sub n n1)
+  | Omul, I n1 :: I n2 :: nil => I(Int.mul n1 n2)
+  | Omulimm n, I n1 :: nil => I(Int.mul n1 n)
+  | Odiv, I n1 :: I n2 :: nil => if Int.eq n2 Int.zero then Unknown else I(Int.divs n1 n2)
+  | Odivu, I n1 :: I n2 :: nil => if Int.eq n2 Int.zero then Unknown else I(Int.divu n1 n2)
+  | Oand, I n1 :: I n2 :: nil => I(Int.and n1 n2)
+  | Oandimm n, I n1 :: nil => I(Int.and n1 n)
+  | Oor, I n1 :: I n2 :: nil => I(Int.or n1 n2)
+  | Oorimm n, I n1 :: nil => I(Int.or n1 n)
+  | Oxor, I n1 :: I n2 :: nil => I(Int.xor n1 n2)
+  | Oxorimm n, I n1 :: nil => I(Int.xor n1 n)
+  | Onand, I n1 :: I n2 :: nil => I(Int.xor (Int.and n1 n2) Int.mone)
+  | Onor, I n1 :: I n2 :: nil => I(Int.xor (Int.or n1 n2) Int.mone)
+  | Onxor, I n1 :: I n2 :: nil => I(Int.xor (Int.xor n1 n2) Int.mone)
+  | Oshl, I n1 :: I n2 :: nil => if Int.ltu n2 (Int.repr 32) then I(Int.shl n1 n2) else Unknown
+  | Oshr, I n1 :: I n2 :: nil => if Int.ltu n2 (Int.repr 32) then I(Int.shr n1 n2) else Unknown
+  | Oshrimm n, I n1 :: nil => if Int.ltu n (Int.repr 32) then I(Int.shr n1 n) else Unknown
+  | Oshrximm n, I n1 :: nil => if Int.ltu n (Int.repr 32) then I(Int.shrx n1 n) else Unknown
+  | Oshru, I n1 :: I n2 :: nil => if Int.ltu n2 (Int.repr 32) then I(Int.shru n1 n2) else Unknown
+  | Orolm amount mask, I n1 :: nil => I(Int.rolm n1 amount mask)
+  | Onegf, F n1 :: nil => F(Float.neg n1)
+  | Oabsf, F n1 :: nil => F(Float.abs n1)
+  | Oaddf, F n1 :: F n2 :: nil => F(Float.add n1 n2)
+  | Osubf, F n1 :: F n2 :: nil => F(Float.sub n1 n2)
+  | Omulf, F n1 :: F n2 :: nil => F(Float.mul n1 n2)
+  | Odivf, F n1 :: F n2 :: nil => F(Float.div n1 n2)
+  | Omuladdf, F n1 :: F n2 :: F n3 :: nil => F(Float.add (Float.mul n1 n2) n3)
+  | Omulsubf, F n1 :: F n2 :: F n3 :: nil => F(Float.sub (Float.mul n1 n2) n3)
+  | Osingleoffloat, F n1 :: nil => F(Float.singleoffloat n1)
+  | Ointoffloat, F n1 :: nil => I(Float.intoffloat n1)
+  | Ointuoffloat, F n1 :: nil => I(Float.intuoffloat n1)
+  | Ofloatofint, I n1 :: nil => F(Float.floatofint n1)
+  | Ofloatofintu, I n1 :: nil => F(Float.floatofintu n1)
+  | Ocmp c, vl =>
+      match eval_static_condition c vl with
+      | None => Unknown
+      | Some b => I(if b then Int.one else Int.zero)
+      end
+  | _, _ => Unknown
+  end.
+*)
+
+Inductive eval_static_operation_cases: forall (op: operation) (vl: list approx), Set :=
+  | eval_static_operation_case1:
+      forall v1,
+      eval_static_operation_cases (Omove) (v1::nil)
+  | eval_static_operation_case2:
+      forall n,
+      eval_static_operation_cases (Ointconst n) (nil)
+  | eval_static_operation_case3:
+      forall n,
+      eval_static_operation_cases (Ofloatconst n) (nil)
+  | eval_static_operation_case4:
+      forall s n,
+      eval_static_operation_cases (Oaddrsymbol s n) (nil)
+  | eval_static_operation_case6:
+      forall n1,
+      eval_static_operation_cases (Ocast8signed) (I n1 :: nil)
+  | eval_static_operation_case7:
+      forall n1,
+      eval_static_operation_cases (Ocast16signed) (I n1 :: nil)
+  | eval_static_operation_case8:
+      forall n1 n2,
+      eval_static_operation_cases (Oadd) (I n1 :: I n2 :: nil)
+  | eval_static_operation_case9:
+      forall s1 n1 n2,
+      eval_static_operation_cases (Oadd) (S s1 n1 :: I n2 :: nil)
+  | eval_static_operation_case11:
+      forall n n1,
+      eval_static_operation_cases (Oaddimm n) (I n1 :: nil)
+  | eval_static_operation_case12:
+      forall n s1 n1,
+      eval_static_operation_cases (Oaddimm n) (S s1 n1 :: nil)
+  | eval_static_operation_case13:
+      forall n1 n2,
+      eval_static_operation_cases (Osub) (I n1 :: I n2 :: nil)
+  | eval_static_operation_case14:
+      forall s1 n1 n2,
+      eval_static_operation_cases (Osub) (S s1 n1 :: I n2 :: nil)
+  | eval_static_operation_case15:
+      forall n n1,
+      eval_static_operation_cases (Osubimm n) (I n1 :: nil)
+  | eval_static_operation_case16:
+      forall n1 n2,
+      eval_static_operation_cases (Omul) (I n1 :: I n2 :: nil)
+  | eval_static_operation_case17:
+      forall n n1,
+      eval_static_operation_cases (Omulimm n) (I n1 :: nil)
+  | eval_static_operation_case18:
+      forall n1 n2,
+      eval_static_operation_cases (Odiv) (I n1 :: I n2 :: nil)
+  | eval_static_operation_case19:
+      forall n1 n2,
+      eval_static_operation_cases (Odivu) (I n1 :: I n2 :: nil)
+  | eval_static_operation_case20:
+      forall n1 n2,
+      eval_static_operation_cases (Oand) (I n1 :: I n2 :: nil)
+  | eval_static_operation_case21:
+      forall n n1,
+      eval_static_operation_cases (Oandimm n) (I n1 :: nil)
+  | eval_static_operation_case22:
+      forall n1 n2,
+      eval_static_operation_cases (Oor) (I n1 :: I n2 :: nil)
+  | eval_static_operation_case23:
+      forall n n1,
+      eval_static_operation_cases (Oorimm n) (I n1 :: nil)
+  | eval_static_operation_case24:
+      forall n1 n2,
+      eval_static_operation_cases (Oxor) (I n1 :: I n2 :: nil)
+  | eval_static_operation_case25:
+      forall n n1,
+      eval_static_operation_cases (Oxorimm n) (I n1 :: nil)
+  | eval_static_operation_case26:
+      forall n1 n2,
+      eval_static_operation_cases (Onand) (I n1 :: I n2 :: nil)
+  | eval_static_operation_case27:
+      forall n1 n2,
+      eval_static_operation_cases (Onor) (I n1 :: I n2 :: nil)
+  | eval_static_operation_case28:
+      forall n1 n2,
+      eval_static_operation_cases (Onxor) (I n1 :: I n2 :: nil)
+  | eval_static_operation_case29:
+      forall n1 n2,
+      eval_static_operation_cases (Oshl) (I n1 :: I n2 :: nil)
+  | eval_static_operation_case30:
+      forall n1 n2,
+      eval_static_operation_cases (Oshr) (I n1 :: I n2 :: nil)
+  | eval_static_operation_case31:
+      forall n n1,
+      eval_static_operation_cases (Oshrimm n) (I n1 :: nil)
+  | eval_static_operation_case32:
+      forall n n1,
+      eval_static_operation_cases (Oshrximm n) (I n1 :: nil)
+  | eval_static_operation_case33:
+      forall n1 n2,
+      eval_static_operation_cases (Oshru) (I n1 :: I n2 :: nil)
+  | eval_static_operation_case34:
+      forall amount mask n1,
+      eval_static_operation_cases (Orolm amount mask) (I n1 :: nil)
+  | eval_static_operation_case35:
+      forall n1,
+      eval_static_operation_cases (Onegf) (F n1 :: nil)
+  | eval_static_operation_case36:
+      forall n1,
+      eval_static_operation_cases (Oabsf) (F n1 :: nil)
+  | eval_static_operation_case37:
+      forall n1 n2,
+      eval_static_operation_cases (Oaddf) (F n1 :: F n2 :: nil)
+  | eval_static_operation_case38:
+      forall n1 n2,
+      eval_static_operation_cases (Osubf) (F n1 :: F n2 :: nil)
+  | eval_static_operation_case39:
+      forall n1 n2,
+      eval_static_operation_cases (Omulf) (F n1 :: F n2 :: nil)
+  | eval_static_operation_case40:
+      forall n1 n2,
+      eval_static_operation_cases (Odivf) (F n1 :: F n2 :: nil)
+  | eval_static_operation_case41:
+      forall n1 n2 n3,
+      eval_static_operation_cases (Omuladdf) (F n1 :: F n2 :: F n3 :: nil)
+  | eval_static_operation_case42:
+      forall n1 n2 n3,
+      eval_static_operation_cases (Omulsubf) (F n1 :: F n2 :: F n3 :: nil)
+  | eval_static_operation_case43:
+      forall n1,
+      eval_static_operation_cases (Osingleoffloat) (F n1 :: nil)
+  | eval_static_operation_case44:
+      forall n1,
+      eval_static_operation_cases (Ointoffloat) (F n1 :: nil)
+  | eval_static_operation_case45:
+      forall n1,
+      eval_static_operation_cases (Ofloatofint) (I n1 :: nil)
+  | eval_static_operation_case46:
+      forall n1,
+      eval_static_operation_cases (Ofloatofintu) (I n1 :: nil)
+  | eval_static_operation_case47:
+      forall c vl,
+      eval_static_operation_cases (Ocmp c) (vl)
+  | eval_static_operation_case48:
+      forall n1,
+      eval_static_operation_cases (Ocast8unsigned) (I n1 :: nil)
+  | eval_static_operation_case49:
+      forall n1,
+      eval_static_operation_cases (Ocast16unsigned) (I n1 :: nil)
+  | eval_static_operation_case50:
+      forall n1,
+      eval_static_operation_cases (Ointuoffloat) (F n1 :: nil)
+  | eval_static_operation_default:
+      forall (op: operation) (vl: list approx),
+      eval_static_operation_cases op vl.
+
+Definition eval_static_operation_match (op: operation) (vl: list approx) :=
+  match op as z1, vl as z2 return eval_static_operation_cases z1 z2 with
+  | Omove, v1::nil =>
+      eval_static_operation_case1 v1
+  | Ointconst n, nil =>
+      eval_static_operation_case2 n
+  | Ofloatconst n, nil =>
+      eval_static_operation_case3 n
+  | Oaddrsymbol s n, nil =>
+      eval_static_operation_case4 s n
+  | Ocast8signed, I n1 :: nil =>
+      eval_static_operation_case6 n1
+  | Ocast16signed, I n1 :: nil =>
+      eval_static_operation_case7 n1
+  | Oadd, I n1 :: I n2 :: nil =>
+      eval_static_operation_case8 n1 n2
+  | Oadd, S s1 n1 :: I n2 :: nil =>
+      eval_static_operation_case9 s1 n1 n2
+  | Oaddimm n, I n1 :: nil =>
+      eval_static_operation_case11 n n1
+  | Oaddimm n, S s1 n1 :: nil =>
+      eval_static_operation_case12 n s1 n1
+  | Osub, I n1 :: I n2 :: nil =>
+      eval_static_operation_case13 n1 n2
+  | Osub, S s1 n1 :: I n2 :: nil =>
+      eval_static_operation_case14 s1 n1 n2
+  | Osubimm n, I n1 :: nil =>
+      eval_static_operation_case15 n n1
+  | Omul, I n1 :: I n2 :: nil =>
+      eval_static_operation_case16 n1 n2
+  | Omulimm n, I n1 :: nil =>
+      eval_static_operation_case17 n n1
+  | Odiv, I n1 :: I n2 :: nil =>
+      eval_static_operation_case18 n1 n2
+  | Odivu, I n1 :: I n2 :: nil =>
+      eval_static_operation_case19 n1 n2
+  | Oand, I n1 :: I n2 :: nil =>
+      eval_static_operation_case20 n1 n2
+  | Oandimm n, I n1 :: nil =>
+      eval_static_operation_case21 n n1
+  | Oor, I n1 :: I n2 :: nil =>
+      eval_static_operation_case22 n1 n2
+  | Oorimm n, I n1 :: nil =>
+      eval_static_operation_case23 n n1
+  | Oxor, I n1 :: I n2 :: nil =>
+      eval_static_operation_case24 n1 n2
+  | Oxorimm n, I n1 :: nil =>
+      eval_static_operation_case25 n n1
+  | Onand, I n1 :: I n2 :: nil =>
+      eval_static_operation_case26 n1 n2
+  | Onor, I n1 :: I n2 :: nil =>
+      eval_static_operation_case27 n1 n2
+  | Onxor, I n1 :: I n2 :: nil =>
+      eval_static_operation_case28 n1 n2
+  | Oshl, I n1 :: I n2 :: nil =>
+      eval_static_operation_case29 n1 n2
+  | Oshr, I n1 :: I n2 :: nil =>
+      eval_static_operation_case30 n1 n2
+  | Oshrimm n, I n1 :: nil =>
+      eval_static_operation_case31 n n1
+  | Oshrximm n, I n1 :: nil =>
+      eval_static_operation_case32 n n1
+  | Oshru, I n1 :: I n2 :: nil =>
+      eval_static_operation_case33 n1 n2
+  | Orolm amount mask, I n1 :: nil =>
+      eval_static_operation_case34 amount mask n1
+  | Onegf, F n1 :: nil =>
+      eval_static_operation_case35 n1
+  | Oabsf, F n1 :: nil =>
+      eval_static_operation_case36 n1
+  | Oaddf, F n1 :: F n2 :: nil =>
+      eval_static_operation_case37 n1 n2
+  | Osubf, F n1 :: F n2 :: nil =>
+      eval_static_operation_case38 n1 n2
+  | Omulf, F n1 :: F n2 :: nil =>
+      eval_static_operation_case39 n1 n2
+  | Odivf, F n1 :: F n2 :: nil =>
+      eval_static_operation_case40 n1 n2
+  | Omuladdf, F n1 :: F n2 :: F n3 :: nil =>
+      eval_static_operation_case41 n1 n2 n3
+  | Omulsubf, F n1 :: F n2 :: F n3 :: nil =>
+      eval_static_operation_case42 n1 n2 n3
+  | Osingleoffloat, F n1 :: nil =>
+      eval_static_operation_case43 n1
+  | Ointoffloat, F n1 :: nil =>
+      eval_static_operation_case44 n1
+  | Ofloatofint, I n1 :: nil =>
+      eval_static_operation_case45 n1
+  | Ofloatofintu, I n1 :: nil =>
+      eval_static_operation_case46 n1
+  | Ocmp c, vl =>
+      eval_static_operation_case47 c vl
+  | Ocast8unsigned, I n1 :: nil =>
+      eval_static_operation_case48 n1
+  | Ocast16unsigned, I n1 :: nil =>
+      eval_static_operation_case49 n1
+  | Ointuoffloat, F n1 :: nil =>
+      eval_static_operation_case50 n1
+  | op, vl =>
+      eval_static_operation_default op vl
+  end.
+
+Definition eval_static_operation (op: operation) (vl: list approx) :=
+  match eval_static_operation_match op vl with
+  | eval_static_operation_case1 v1 =>
+      v1
+  | eval_static_operation_case2 n =>
+      I n
+  | eval_static_operation_case3 n =>
+      F n
+  | eval_static_operation_case4 s n =>
+      S s n
+  | eval_static_operation_case6 n1 =>
+      I(Int.sign_ext 8 n1)
+  | eval_static_operation_case7 n1 =>
+      I(Int.sign_ext 16 n1)
+  | eval_static_operation_case8 n1 n2 =>
+      I(Int.add n1 n2)
+  | eval_static_operation_case9 s1 n1 n2 =>
+      S s1 (Int.add n1 n2)
+  | eval_static_operation_case11 n n1 =>
+      I (Int.add n1 n)
+  | eval_static_operation_case12 n s1 n1 =>
+      S s1 (Int.add n1 n)
+  | eval_static_operation_case13 n1 n2 =>
+      I(Int.sub n1 n2)
+  | eval_static_operation_case14 s1 n1 n2 =>
+      S s1 (Int.sub n1 n2)
+  | eval_static_operation_case15 n n1 =>
+      I (Int.sub n n1)
+  | eval_static_operation_case16 n1 n2 =>
+      I(Int.mul n1 n2)
+  | eval_static_operation_case17 n n1 =>
+      I(Int.mul n1 n)
+  | eval_static_operation_case18 n1 n2 =>
+      if Int.eq n2 Int.zero then Unknown else I(Int.divs n1 n2)
+  | eval_static_operation_case19 n1 n2 =>
+      if Int.eq n2 Int.zero then Unknown else I(Int.divu n1 n2)
+  | eval_static_operation_case20 n1 n2 =>
+      I(Int.and n1 n2)
+  | eval_static_operation_case21 n n1 =>
+      I(Int.and n1 n)
+  | eval_static_operation_case22 n1 n2 =>
+      I(Int.or n1 n2)
+  | eval_static_operation_case23 n n1 =>
+      I(Int.or n1 n)
+  | eval_static_operation_case24 n1 n2 =>
+      I(Int.xor n1 n2)
+  | eval_static_operation_case25 n n1 =>
+      I(Int.xor n1 n)
+  | eval_static_operation_case26 n1 n2 =>
+      I(Int.xor (Int.and n1 n2) Int.mone)
+  | eval_static_operation_case27 n1 n2 =>
+      I(Int.xor (Int.or n1 n2) Int.mone)
+  | eval_static_operation_case28 n1 n2 =>
+      I(Int.xor (Int.xor n1 n2) Int.mone)
+  | eval_static_operation_case29 n1 n2 =>
+      if Int.ltu n2 (Int.repr 32) then I(Int.shl n1 n2) else Unknown
+  | eval_static_operation_case30 n1 n2 =>
+      if Int.ltu n2 (Int.repr 32) then I(Int.shr n1 n2) else Unknown
+  | eval_static_operation_case31 n n1 =>
+      if Int.ltu n (Int.repr 32) then I(Int.shr n1 n) else Unknown
+  | eval_static_operation_case32 n n1 =>
+      if Int.ltu n (Int.repr 32) then I(Int.shrx n1 n) else Unknown
+  | eval_static_operation_case33 n1 n2 =>
+      if Int.ltu n2 (Int.repr 32) then I(Int.shru n1 n2) else Unknown
+  | eval_static_operation_case34 amount mask n1 =>
+      I(Int.rolm n1 amount mask)
+  | eval_static_operation_case35 n1 =>
+      F(Float.neg n1)
+  | eval_static_operation_case36 n1 =>
+      F(Float.abs n1)
+  | eval_static_operation_case37 n1 n2 =>
+      F(Float.add n1 n2)
+  | eval_static_operation_case38 n1 n2 =>
+      F(Float.sub n1 n2)
+  | eval_static_operation_case39 n1 n2 =>
+      F(Float.mul n1 n2)
+  | eval_static_operation_case40 n1 n2 =>
+      F(Float.div n1 n2)
+  | eval_static_operation_case41 n1 n2 n3 =>
+      F(Float.add (Float.mul n1 n2) n3)
+  | eval_static_operation_case42 n1 n2 n3 =>
+      F(Float.sub (Float.mul n1 n2) n3)
+  | eval_static_operation_case43 n1 =>
+      F(Float.singleoffloat n1)
+  | eval_static_operation_case44 n1 =>
+      I(Float.intoffloat n1)
+  | eval_static_operation_case45 n1 =>
+      F(Float.floatofint n1)
+  | eval_static_operation_case46 n1 =>
+      F(Float.floatofintu n1)
+  | eval_static_operation_case47 c vl =>
+      match eval_static_condition c vl with
+      | None => Unknown
+      | Some b => I(if b then Int.one else Int.zero)
+      end
+  | eval_static_operation_case48 n1 =>
+      I(Int.zero_ext 8 n1)
+  | eval_static_operation_case49 n1 =>
+      I(Int.zero_ext 16 n1)
+  | eval_static_operation_case50 n1 =>
+      I(Float.intuoffloat n1)
+  | eval_static_operation_default op vl =>
+      Unknown
+  end.
+
+(** The transfer function for the dataflow analysis is straightforward:
+  for [Iop] instructions, we set the approximation of the destination
+  register to the result of executing abstractly the operation;
+  for [Iload] and [Icall], we set the approximation of the destination
+  to [Unknown]. *)
+
+Definition approx_regs (rl: list reg) (approx: D.t) :=
+  List.map (fun r => D.get r approx) rl.
+
+Definition transfer (f: function) (pc: node) (before: D.t) :=
+  match f.(fn_code)!pc with
+  | None => before
+  | Some i =>
+      match i with
+      | Inop s =>
+          before
+      | Iop op args res s =>
+          let a := eval_static_operation op (approx_regs args before) in
+          D.set res a before
+      | Iload chunk addr args dst s =>
+          D.set dst Unknown before
+      | Istore chunk addr args src s =>
+          before
+      | Icall sig ros args res s =>
+          D.set res Unknown before
+      | Itailcall sig ros args =>
+          before
+      | Ialloc arg res s =>
+          D.set res Unknown before
+      | Icond cond args ifso ifnot =>
+          before
+      | Ireturn optarg =>
+          before
+      end
+  end.
+
+(** The static analysis itself is then an instantiation of Kildall's
+  generic solver for forward dataflow inequations. [analyze f]
+  returns a mapping from program points to mappings of pseudo-registers
+  to approximations.  It can fail to reach a fixpoint in a reasonable
+  number of iterations, in which case [None] is returned. *)
+
+Module DS := Dataflow_Solver(D)(NodeSetForward).
+
+Definition analyze (f: RTL.function): PMap.t D.t :=
+  match DS.fixpoint (successors f) f.(fn_nextpc) (transfer f) 
+                    ((f.(fn_entrypoint), D.top) :: nil) with
+  | None => PMap.init D.top
+  | Some res => res
+  end.
+
+(** * Code transformation *)
+
+(** ** Operator strength reduction *)
+
+(** We now define auxiliary functions for strength reduction of
+  operators and addressing modes: replacing an operator with a cheaper
+  one if some of its arguments are statically known.  These are again
+  large pattern-matchings expressed in indirect style. *)
+
+Section STRENGTH_REDUCTION.
+
+Variable approx: D.t.
+
+Definition intval (r: reg) : option int :=
+  match D.get r approx with I n => Some n | _ => None end.
+
+Inductive cond_strength_reduction_cases: condition -> list reg -> Set :=
+  | csr_case1:
+      forall c r1 r2,
+      cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil)
+  | csr_case2:
+      forall c r1 r2,
+      cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil)
+  | csr_default:
+      forall c rl,
+      cond_strength_reduction_cases c rl.
+
+Definition cond_strength_reduction_match (cond: condition) (rl: list reg) :=
+  match cond as x, rl as y return cond_strength_reduction_cases x y with
+  | Ccomp c, r1 :: r2 :: nil =>
+      csr_case1 c r1 r2
+  | Ccompu c, r1 :: r2 :: nil =>
+      csr_case2 c r1 r2
+  | cond, rl =>
+      csr_default cond rl
+  end.
+
+Definition cond_strength_reduction
+              (cond: condition) (args: list reg) : condition * list reg :=
+  match cond_strength_reduction_match cond args with
+  | csr_case1 c r1 r2 =>
+      match intval r1, intval r2 with
+      | Some n, _ =>
+          (Ccompimm (swap_comparison c) n, r2 :: nil)
+      | _, Some n =>
+          (Ccompimm c n, r1 :: nil)
+      | _, _ =>
+          (cond, args)
+      end
+  | csr_case2 c r1 r2 =>
+      match intval r1, intval r2 with
+      | Some n, _ =>
+          (Ccompuimm (swap_comparison c) n, r2 :: nil)
+      | _, Some n =>
+          (Ccompuimm c n, r1 :: nil)
+      | _, _ =>
+          (cond, args)
+      end
+  | csr_default cond args =>
+      (cond, args)
+  end.
+
+Definition make_addimm (n: int) (r: reg) :=
+  if Int.eq n Int.zero
+  then (Omove, r :: nil)
+  else (Oaddimm n, r :: nil).
+
+Definition make_shlimm (n: int) (r: reg) :=
+  if Int.eq n Int.zero
+  then (Omove, r :: nil)
+  else (Orolm n (Int.shl Int.mone n), r :: nil).
+
+Definition make_shrimm (n: int) (r: reg) :=
+  if Int.eq n Int.zero
+  then (Omove, r :: nil)
+  else (Oshrimm n, r :: nil).
+
+Definition make_shruimm (n: int) (r: reg) :=
+  if Int.eq n Int.zero
+  then (Omove, r :: nil)
+  else (Orolm (Int.sub (Int.repr 32) n) (Int.shru Int.mone n), r :: nil).
+
+Definition make_mulimm (n: int) (r: reg) :=
+  if Int.eq n Int.zero then
+    (Ointconst Int.zero, nil)
+  else if Int.eq n Int.one then
+    (Omove, r :: nil)
+  else
+    match Int.is_power2 n with
+    | Some l => make_shlimm l r
+    | None => (Omulimm n, r :: nil)
+    end.
+
+Definition make_andimm (n: int) (r: reg) :=
+  if Int.eq n Int.zero
+  then (Ointconst Int.zero, nil)
+  else if Int.eq n Int.mone then (Omove, r :: nil)
+  else (Oandimm n, r :: nil).
+
+Definition make_orimm (n: int) (r: reg) :=
+  if Int.eq n Int.zero then (Omove, r :: nil)
+  else if Int.eq n Int.mone then (Ointconst Int.mone, nil)
+  else (Oorimm n, r :: nil).
+
+Definition make_xorimm (n: int) (r: reg) :=
+  if Int.eq n Int.zero
+  then (Omove, r :: nil)
+  else (Oxorimm n, r :: nil).
+
+Inductive op_strength_reduction_cases: operation -> list reg -> Set :=
+  | op_strength_reduction_case1:
+      forall (r1: reg) (r2: reg),
+      op_strength_reduction_cases Oadd (r1 :: r2 :: nil)
+  | op_strength_reduction_case2:
+      forall (r1: reg) (r2: reg),
+      op_strength_reduction_cases Osub (r1 :: r2 :: nil)
+  | op_strength_reduction_case3:
+      forall (r1: reg) (r2: reg),
+      op_strength_reduction_cases Omul (r1 :: r2 :: nil)
+  | op_strength_reduction_case4:
+      forall (r1: reg) (r2: reg),
+      op_strength_reduction_cases Odiv (r1 :: r2 :: nil)
+  | op_strength_reduction_case5:
+      forall (r1: reg) (r2: reg),
+      op_strength_reduction_cases Odivu (r1 :: r2 :: nil)
+  | op_strength_reduction_case6:
+      forall (r1: reg) (r2: reg),
+      op_strength_reduction_cases Oand (r1 :: r2 :: nil)
+  | op_strength_reduction_case7:
+      forall (r1: reg) (r2: reg),
+      op_strength_reduction_cases Oor (r1 :: r2 :: nil)
+  | op_strength_reduction_case8:
+      forall (r1: reg) (r2: reg),
+      op_strength_reduction_cases Oxor (r1 :: r2 :: nil)
+  | op_strength_reduction_case9:
+      forall (r1: reg) (r2: reg),
+      op_strength_reduction_cases Oshl (r1 :: r2 :: nil)
+  | op_strength_reduction_case10:
+      forall (r1: reg) (r2: reg),
+      op_strength_reduction_cases Oshr (r1 :: r2 :: nil)
+  | op_strength_reduction_case11:
+      forall (r1: reg) (r2: reg),
+      op_strength_reduction_cases Oshru (r1 :: r2 :: nil)
+  | op_strength_reduction_case12:
+      forall (c: condition) (rl: list reg),
+      op_strength_reduction_cases (Ocmp c) rl
+  | op_strength_reduction_default:
+      forall (op: operation) (args: list reg),
+      op_strength_reduction_cases op args.
+
+Definition op_strength_reduction_match (op: operation) (args: list reg) :=
+  match op as z1, args as z2 return op_strength_reduction_cases z1 z2 with
+  | Oadd, r1 :: r2 :: nil =>
+      op_strength_reduction_case1 r1 r2
+  | Osub, r1 :: r2 :: nil =>
+      op_strength_reduction_case2 r1 r2
+  | Omul, r1 :: r2 :: nil =>
+      op_strength_reduction_case3 r1 r2
+  | Odiv, r1 :: r2 :: nil =>
+      op_strength_reduction_case4 r1 r2
+  | Odivu, r1 :: r2 :: nil =>
+      op_strength_reduction_case5 r1 r2
+  | Oand, r1 :: r2 :: nil =>
+      op_strength_reduction_case6 r1 r2
+  | Oor, r1 :: r2 :: nil =>
+      op_strength_reduction_case7 r1 r2
+  | Oxor, r1 :: r2 :: nil =>
+      op_strength_reduction_case8 r1 r2
+  | Oshl, r1 :: r2 :: nil =>
+      op_strength_reduction_case9 r1 r2
+  | Oshr, r1 :: r2 :: nil =>
+      op_strength_reduction_case10 r1 r2
+  | Oshru, r1 :: r2 :: nil =>
+      op_strength_reduction_case11 r1 r2
+  | Ocmp c, rl =>
+      op_strength_reduction_case12 c rl
+  | op, args =>
+      op_strength_reduction_default op args
+  end.
+
+Definition op_strength_reduction (op: operation) (args: list reg) :=
+  match op_strength_reduction_match op args with
+  | op_strength_reduction_case1 r1 r2 => (* Oadd *)
+      match intval r1, intval r2 with
+      | Some n, _ => make_addimm n r2
+      | _, Some n => make_addimm n r1
+      | _, _ => (op, args)
+      end
+  | op_strength_reduction_case2 r1 r2 => (* Osub *)
+      match intval r1, intval r2 with
+      | Some n, _ => (Osubimm n, r2 :: nil)
+      | _, Some n => make_addimm (Int.neg n) r1
+      | _, _ => (op, args)
+      end
+  | op_strength_reduction_case3 r1 r2 => (* Omul *)
+      match intval r1, intval r2 with
+      | Some n, _ => make_mulimm n r2
+      | _, Some n => make_mulimm n r1
+      | _, _ => (op, args)
+      end
+  | op_strength_reduction_case4 r1 r2 => (* Odiv *)
+      match intval r2 with
+      | Some n =>
+          match Int.is_power2 n with
+          | Some l => (Oshrximm l, r1 :: nil)
+          | None   => (op, args)
+          end
+      | None =>
+          (op, args)
+      end
+  | op_strength_reduction_case5 r1 r2 => (* Odivu *)
+      match intval r2 with
+      | Some n =>
+          match Int.is_power2 n with
+          | Some l => make_shruimm l r1
+          | None   => (op, args)
+          end
+      | None =>
+          (op, args)
+      end
+  | op_strength_reduction_case6 r1 r2 => (* Oand *)
+      match intval r1, intval r2 with
+      | Some n, _ => make_andimm n r2
+      | _, Some n => make_andimm n r1
+      | _, _ => (op, args)
+      end
+  | op_strength_reduction_case7 r1 r2 => (* Oor *)
+      match intval r1, intval r2 with
+      | Some n, _ => make_orimm n r2
+      | _, Some n => make_orimm n r1
+      | _, _ => (op, args)
+      end
+  | op_strength_reduction_case8 r1 r2 => (* Oxor *)
+      match intval r1, intval r2 with
+      | Some n, _ => make_xorimm n r2
+      | _, Some n => make_xorimm n r1
+      | _, _ => (op, args)
+      end
+  | op_strength_reduction_case9 r1 r2 => (* Oshl *)
+      match intval r2 with
+      | Some n =>
+          if Int.ltu n (Int.repr 32)
+          then make_shlimm n r1
+          else (op, args)
+      | _ => (op, args)
+      end
+  | op_strength_reduction_case10 r1 r2 => (* Oshr *)
+      match intval r2 with
+      | Some n =>
+          if Int.ltu n (Int.repr 32)
+          then make_shrimm n r1
+          else (op, args)
+      | _ => (op, args)
+      end
+  | op_strength_reduction_case11 r1 r2 => (* Oshru *)
+      match intval r2 with
+      | Some n =>
+          if Int.ltu n (Int.repr 32)
+          then make_shruimm n r1
+          else (op, args)
+      | _ => (op, args)
+      end
+  | op_strength_reduction_case12 c args => (* Ocmp *)
+      let (c', args') := cond_strength_reduction c args in
+      (Ocmp c', args')
+  | op_strength_reduction_default op args => (* default *)
+      (op, args)
+  end.
+
+Inductive addr_strength_reduction_cases: forall (addr: addressing) (args: list reg), Set :=
+  | addr_strength_reduction_case1:
+      forall (r1: reg) (r2: reg),
+      addr_strength_reduction_cases (Aindexed2) (r1 :: r2 :: nil)
+  | addr_strength_reduction_case2:
+      forall (symb: ident) (ofs: int) (r1: reg),
+      addr_strength_reduction_cases (Abased symb ofs) (r1 :: nil)
+  | addr_strength_reduction_case3:
+      forall n r1,
+      addr_strength_reduction_cases (Aindexed n) (r1 :: nil)
+  | addr_strength_reduction_default:
+      forall (addr: addressing) (args: list reg),
+      addr_strength_reduction_cases addr args.
+
+Definition addr_strength_reduction_match (addr: addressing) (args: list reg) :=
+  match addr as z1, args as z2 return addr_strength_reduction_cases z1 z2 with
+  | Aindexed2, r1 :: r2 :: nil =>
+      addr_strength_reduction_case1 r1 r2
+  | Abased symb ofs, r1 :: nil =>
+      addr_strength_reduction_case2 symb ofs r1
+  | Aindexed n, r1 :: nil =>
+      addr_strength_reduction_case3 n r1
+  | addr, args =>
+      addr_strength_reduction_default addr args
+  end.
+
+Definition addr_strength_reduction (addr: addressing) (args: list reg) :=
+  match addr_strength_reduction_match addr args with
+  | addr_strength_reduction_case1 r1 r2 => (* Aindexed2 *)
+      match D.get r1 approx, D.get r2 approx with
+      | S symb n1, I n2 => (Aglobal symb (Int.add n1 n2), nil)
+      | S symb n1, _ => (Abased symb n1, r2 :: nil)
+      | I n1, S symb n2 => (Aglobal symb (Int.add n1 n2), nil)
+      | I n1, _ => (Aindexed n1, r2 :: nil)
+      | _, S symb n2 => (Abased symb n2, r1 :: nil)
+      | _, I n2 => (Aindexed n2, r1 :: nil)
+      | _, _ => (addr, args)
+      end
+  | addr_strength_reduction_case2 symb ofs r1 => (* Abased *)
+      match intval r1 with
+      | Some n => (Aglobal symb (Int.add ofs n), nil)
+      | _ => (addr, args)
+      end
+  | addr_strength_reduction_case3 n r1 => (* Aindexed *)
+      match D.get r1 approx with
+      | S symb ofs => (Aglobal symb (Int.add ofs n), nil)
+      | _ => (addr, args)
+      end
+  | addr_strength_reduction_default addr args => (* default *)
+      (addr, args)
+  end.
+
+End STRENGTH_REDUCTION.
+
+(** ** Code transformation *)
+
+(** The code transformation proceeds instruction by instruction.
+    Operators whose arguments are all statically known are turned
+    into ``load integer constant'', ``load float constant'' or
+    ``load symbol address'' operations.  Operators for which some
+    but not all arguments are known are subject to strength reduction,
+    and similarly for the addressing modes of load and store instructions.
+    Other instructions are unchanged. *)
+
+Definition transf_ros (approx: D.t) (ros: reg + ident) : reg + ident :=
+  match ros with
+  | inl r =>
+      match D.get r approx with
+      | S symb ofs => if Int.eq ofs Int.zero then inr _ symb else ros
+      | _ => ros
+      end
+  | inr s => ros
+  end.
+
+Definition transf_instr (approx: D.t) (instr: instruction) :=
+  match instr with
+  | Iop op args res s =>
+      match eval_static_operation op (approx_regs args approx) with
+      | I n =>
+          Iop (Ointconst n) nil res s
+      | F n =>
+          Iop (Ofloatconst n) nil res s
+      | S symb ofs =>
+          Iop (Oaddrsymbol symb ofs) nil res s
+      | _ =>
+          let (op', args') := op_strength_reduction approx op args in
+          Iop op' args' res s
+      end
+  | Iload chunk addr args dst s =>
+      let (addr', args') := addr_strength_reduction approx addr args in
+      Iload chunk addr' args' dst s      
+  | Istore chunk addr args src s =>
+      let (addr', args') := addr_strength_reduction approx addr args in
+      Istore chunk addr' args' src s      
+  | Icall sig ros args res s =>
+      Icall sig (transf_ros approx ros) args res s
+  | Itailcall sig ros args =>
+      Itailcall sig (transf_ros approx ros) args
+  | Ialloc arg res s =>
+      Ialloc arg res s
+  | Icond cond args s1 s2 =>
+      match eval_static_condition cond (approx_regs args approx) with
+      | Some b =>
+          if b then Inop s1 else Inop s2
+      | None =>
+          let (cond', args') := cond_strength_reduction approx cond args in
+          Icond cond' args' s1 s2
+      end
+  | _ =>
+      instr
+  end.
+
+Definition transf_code (approxs: PMap.t D.t) (instrs: code) : code :=
+  PTree.map (fun pc instr => transf_instr approxs!!pc instr) instrs.
+
+Lemma transf_code_wf:
+  forall f approxs,
+  (forall pc, Plt pc f.(fn_nextpc) \/ f.(fn_code)!pc = None) ->
+  (forall pc, Plt pc f.(fn_nextpc)
+      \/ (transf_code approxs f.(fn_code))!pc = None).
+Proof.
+  intros. 
+  elim (H pc); intro.
+  left; auto.
+  right. unfold transf_code. rewrite PTree.gmap. 
+  unfold option_map; rewrite H0. reflexivity.
+Qed.
+
+Definition transf_function (f: function) : function :=
+  let approxs := analyze f in
+  mkfunction
+    f.(fn_sig)
+    f.(fn_params)
+    f.(fn_stacksize)
+    (transf_code approxs f.(fn_code))
+    f.(fn_entrypoint)
+    f.(fn_nextpc)
+    (transf_code_wf f approxs f.(fn_code_wf)).
+
+Definition transf_fundef (fd: fundef) : fundef :=
+  AST.transf_fundef transf_function fd.
+
+Definition transf_program (p: program) : program :=
+  transform_program transf_fundef p.
diff --git a/powerpc/Constpropproof.v b/powerpc/Constpropproof.v
new file mode 100644
index 00000000..e16f322e
--- /dev/null
+++ b/powerpc/Constpropproof.v
@@ -0,0 +1,954 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              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 constant propagation. *)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Events.
+Require Import Mem.
+Require Import Globalenvs.
+Require Import Smallstep.
+Require Import Op.
+Require Import Registers.
+Require Import RTL.
+Require Import Lattice.
+Require Import Kildall.
+Require Import Constprop.
+
+(** * Correctness of the static analysis *)
+
+Section ANALYSIS.
+
+Variable ge: genv.
+
+(** We first show that the dataflow analysis is correct with respect
+  to the dynamic semantics: the approximations (sets of values) 
+  of a register at a program point predicted by the static analysis
+  are a superset of the values actually encountered during concrete
+  executions.  We formalize this correspondence between run-time values and
+  compile-time approximations by the following predicate. *)
+
+Definition val_match_approx (a: approx) (v: val) : Prop :=
+  match a with
+  | Unknown => True
+  | I p => v = Vint p
+  | F p => v = Vfloat p
+  | S symb ofs => exists b, Genv.find_symbol ge symb = Some b /\ v = Vptr b ofs
+  | _ => False
+  end.
+
+Definition regs_match_approx (a: D.t) (rs: regset) : Prop :=
+  forall r, val_match_approx (D.get r a) rs#r.
+
+Lemma regs_match_approx_top:
+  forall rs, regs_match_approx D.top rs.
+Proof.
+  intros. red; intros. simpl. rewrite PTree.gempty. 
+  unfold Approx.top, val_match_approx. auto.
+Qed.
+
+Lemma val_match_approx_increasing:
+  forall a1 a2 v,
+  Approx.ge a1 a2 -> val_match_approx a2 v -> val_match_approx a1 v.
+Proof.
+  intros until v.
+  intros [A|[B|C]].
+  subst a1. simpl. auto.
+  subst a2. simpl. tauto.
+  subst a2. auto.
+Qed.
+
+Lemma regs_match_approx_increasing:
+  forall a1 a2 rs,
+  D.ge a1 a2 -> regs_match_approx a2 rs -> regs_match_approx a1 rs.
+Proof.
+  unfold D.ge, regs_match_approx. intros.
+  apply val_match_approx_increasing with (D.get r a2); auto.
+Qed.
+
+Lemma regs_match_approx_update:
+  forall ra rs a v r,
+  val_match_approx a v ->
+  regs_match_approx ra rs ->
+  regs_match_approx (D.set r a ra) (rs#r <- v).
+Proof.
+  intros; red; intros. rewrite Regmap.gsspec. 
+  case (peq r0 r); intro.
+  subst r0. rewrite D.gss. auto.
+  rewrite D.gso; auto. 
+Qed.
+
+Inductive val_list_match_approx: list approx -> list val -> Prop :=
+  | vlma_nil:
+      val_list_match_approx nil nil
+  | vlma_cons:
+      forall a al v vl,
+      val_match_approx a v ->
+      val_list_match_approx al vl ->
+      val_list_match_approx (a :: al) (v :: vl).
+
+Lemma approx_regs_val_list:
+  forall ra rs rl,
+  regs_match_approx ra rs ->
+  val_list_match_approx (approx_regs rl ra) rs##rl.
+Proof.
+  induction rl; simpl; intros.
+  constructor.
+  constructor. apply H. auto.
+Qed.
+
+Ltac SimplVMA :=
+  match goal with
+  | H: (val_match_approx (I _) ?v) |- _ =>
+      simpl in H; (try subst v); SimplVMA
+  | H: (val_match_approx (F _) ?v) |- _ =>
+      simpl in H; (try subst v); SimplVMA
+  | H: (val_match_approx (S _ _) ?v) |- _ =>
+      simpl in H; 
+      (try (elim H;
+            let b := fresh "b" in let A := fresh in let B := fresh in
+            (intros b [A B]; subst v; clear H)));
+      SimplVMA
+  | _ =>
+      idtac
+  end.
+
+Ltac InvVLMA :=
+  match goal with
+  | H: (val_list_match_approx nil ?vl) |- _ =>
+      inversion H
+  | H: (val_list_match_approx (?a :: ?al) ?vl) |- _ =>
+      inversion H; SimplVMA; InvVLMA
+  | _ =>
+      idtac
+  end.
+
+(** We then show that [eval_static_operation] is a correct abstract
+  interpretations of [eval_operation]: if the concrete arguments match
+  the given approximations, the concrete results match the
+  approximations returned by [eval_static_operation]. *)
+
+Lemma eval_static_condition_correct:
+  forall cond al vl m b,
+  val_list_match_approx al vl ->
+  eval_static_condition cond al = Some b ->
+  eval_condition cond vl m = Some b.
+Proof.
+  intros until b.
+  unfold eval_static_condition. 
+  case (eval_static_condition_match cond al); intros;
+  InvVLMA; simpl; congruence.
+Qed.
+
+Lemma eval_static_operation_correct:
+  forall op sp al vl m v,
+  val_list_match_approx al vl ->
+  eval_operation ge sp op vl m = Some v ->
+  val_match_approx (eval_static_operation op al) v.
+Proof.
+  intros until v.
+  unfold eval_static_operation. 
+  case (eval_static_operation_match op al); intros;
+  InvVLMA; simpl in *; FuncInv; try congruence.
+
+  destruct (Genv.find_symbol ge s). exists b. intuition congruence.
+  congruence.
+
+  rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence.
+  rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence.
+
+  exists b. split. auto. congruence. 
+  exists b. split. auto. congruence.
+  exists b. split. auto. congruence.
+
+  replace n2 with i0. destruct (Int.eq i0 Int.zero). 
+  discriminate. injection H0; intro; subst v. simpl. congruence. congruence.
+
+  replace n2 with i0. destruct (Int.eq i0 Int.zero). 
+  discriminate. injection H0; intro; subst v. simpl. congruence. congruence.
+
+  subst v. unfold Int.not. congruence.
+  subst v. unfold Int.not. congruence.
+  subst v. unfold Int.not. congruence.
+
+  replace n2 with i0. destruct (Int.ltu i0 (Int.repr 32)).
+  injection H0; intro; subst v. simpl. congruence. discriminate. congruence. 
+
+  replace n2 with i0. destruct (Int.ltu i0 (Int.repr 32)).
+  injection H0; intro; subst v. simpl. congruence. discriminate. congruence. 
+
+  destruct (Int.ltu n (Int.repr 32)).
+  injection H0; intro; subst v. simpl. congruence. discriminate. 
+
+  destruct (Int.ltu n (Int.repr 32)).
+  injection H0; intro; subst v. simpl. congruence. discriminate. 
+
+  replace n2 with i0. destruct (Int.ltu i0 (Int.repr 32)).
+  injection H0; intro; subst v. simpl. congruence. discriminate. congruence. 
+
+  rewrite <- H3. replace v0 with (Vfloat n1). reflexivity. congruence.
+
+  caseEq (eval_static_condition c vl0).
+  intros. generalize (eval_static_condition_correct _ _ _ m _ H H1).
+  intro. rewrite H2 in H0. 
+  destruct b; injection H0; intro; subst v; simpl; auto.
+  intros; simpl; auto.
+
+  rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence.
+  rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence.
+
+  auto.
+Qed.
+
+(** The correctness of the static analysis follows from the results
+  above and the fact that the result of the static analysis is
+  a solution of the forward dataflow inequations. *)
+
+Lemma analyze_correct_1:
+  forall f pc rs pc',
+  In pc' (successors f pc) ->
+  regs_match_approx (transfer f pc (analyze f)!!pc) rs ->
+  regs_match_approx (analyze f)!!pc' rs.
+Proof.
+  intros until pc'. unfold analyze. 
+  caseEq (DS.fixpoint (successors f) (fn_nextpc f) (transfer f)
+                      ((fn_entrypoint f, D.top) :: nil)).
+  intros approxs; intros.
+  apply regs_match_approx_increasing with (transfer f pc approxs!!pc).
+  eapply DS.fixpoint_solution; eauto.
+  elim (fn_code_wf f pc); intro. auto. 
+  unfold successors in H0; rewrite H2 in H0; simpl; contradiction.
+  auto.
+  intros. rewrite PMap.gi. apply regs_match_approx_top. 
+Qed.
+
+Lemma analyze_correct_3:
+  forall f rs,
+  regs_match_approx (analyze f)!!(f.(fn_entrypoint)) rs.
+Proof.
+  intros. unfold analyze. 
+  caseEq (DS.fixpoint (successors f) (fn_nextpc f) (transfer f)
+                      ((fn_entrypoint f, D.top) :: nil)).
+  intros approxs; intros.
+  apply regs_match_approx_increasing with D.top.
+  eapply DS.fixpoint_entry; eauto. auto with coqlib.
+  apply regs_match_approx_top. 
+  intros. rewrite PMap.gi. apply regs_match_approx_top.
+Qed.
+
+(** * Correctness of strength reduction *)
+
+(** We now show that strength reduction over operators and addressing
+  modes preserve semantics: the strength-reduced operations and
+  addressings evaluate to the same values as the original ones if the
+  actual arguments match the static approximations used for strength
+  reduction. *)
+
+Section STRENGTH_REDUCTION.
+
+Variable approx: D.t.
+Variable sp: val.
+Variable rs: regset.
+Hypothesis MATCH: regs_match_approx approx rs.
+
+Lemma intval_correct:
+  forall r n,
+  intval approx r = Some n -> rs#r = Vint n.
+Proof.
+  intros until n.
+  unfold intval. caseEq (D.get r approx); intros; try discriminate.
+  generalize (MATCH r). unfold val_match_approx. rewrite H.
+  congruence. 
+Qed.
+
+Lemma cond_strength_reduction_correct:
+  forall cond args m,
+  let (cond', args') := cond_strength_reduction approx cond args in
+  eval_condition cond' rs##args' m = eval_condition cond rs##args m.
+Proof.
+  intros. unfold cond_strength_reduction.
+  case (cond_strength_reduction_match cond args); intros.
+  caseEq (intval approx r1); intros.
+  simpl. rewrite (intval_correct _ _ H). 
+  destruct (rs#r2); auto. rewrite Int.swap_cmp. auto.
+  destruct c; reflexivity.
+  caseEq (intval approx r2); intros.
+  simpl. rewrite (intval_correct _ _ H0). auto.
+  auto.
+  caseEq (intval approx r1); intros.
+  simpl. rewrite (intval_correct _ _ H). 
+  destruct (rs#r2); auto. rewrite Int.swap_cmpu. auto.
+  caseEq (intval approx r2); intros.
+  simpl. rewrite (intval_correct _ _ H0). auto.
+  auto.
+  auto.
+Qed.
+
+Lemma make_addimm_correct:
+  forall n r m v,
+  let (op, args) := make_addimm n r in
+  eval_operation ge sp Oadd (rs#r :: Vint n :: nil) m = Some v ->
+  eval_operation ge sp op rs##args m = Some v.
+Proof.
+  intros; unfold make_addimm.
+  generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros.
+  subst n. simpl in *. FuncInv. rewrite Int.add_zero in H. congruence.
+  rewrite Int.add_zero in H. congruence.
+  exact H0.
+Qed.
+  
+Lemma make_shlimm_correct:
+  forall n r m v,
+  let (op, args) := make_shlimm n r in
+  eval_operation ge sp Oshl (rs#r :: Vint n :: nil) m = Some v ->
+  eval_operation ge sp op rs##args m = Some v.
+Proof.
+  intros; unfold make_shlimm.
+  generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros.
+  subst n. simpl in *. FuncInv. rewrite Int.shl_zero in H. congruence.
+  simpl in *. FuncInv. caseEq (Int.ltu n (Int.repr 32)); intros.
+  rewrite H1 in H0. rewrite Int.shl_rolm in H0. auto. exact H1.
+  rewrite H1 in H0. discriminate.
+Qed.
+
+Lemma make_shrimm_correct:
+  forall n r m v,
+  let (op, args) := make_shrimm n r in
+  eval_operation ge sp Oshr (rs#r :: Vint n :: nil) m = Some v ->
+  eval_operation ge sp op rs##args m = Some v.
+Proof.
+  intros; unfold make_shrimm.
+  generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros.
+  subst n. simpl in *. FuncInv. rewrite Int.shr_zero in H. congruence.
+  assumption.
+Qed.
+
+Lemma make_shruimm_correct:
+  forall n r m v,
+  let (op, args) := make_shruimm n r in
+  eval_operation ge sp Oshru (rs#r :: Vint n :: nil) m = Some v ->
+  eval_operation ge sp op rs##args m = Some v.
+Proof.
+  intros; unfold make_shruimm.
+  generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros.
+  subst n. simpl in *. FuncInv. rewrite Int.shru_zero in H. congruence.
+  simpl in *. FuncInv. caseEq (Int.ltu n (Int.repr 32)); intros.
+  rewrite H1 in H0. rewrite Int.shru_rolm in H0. auto. exact H1.
+  rewrite H1 in H0. discriminate.
+Qed.
+
+Lemma make_mulimm_correct:
+  forall n r m v,
+  let (op, args) := make_mulimm n r in
+  eval_operation ge sp Omul (rs#r :: Vint n :: nil) m = Some v ->
+  eval_operation ge sp op rs##args m = Some v.
+Proof.
+  intros; unfold make_mulimm.
+  generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros.
+  subst n. simpl in H0. FuncInv. rewrite Int.mul_zero in H. simpl. congruence.
+  generalize (Int.eq_spec n Int.one); case (Int.eq n Int.one); intros.
+  subst n. simpl in H1. simpl. FuncInv. rewrite Int.mul_one in H0. congruence.
+  caseEq (Int.is_power2 n); intros.
+  replace (eval_operation ge sp Omul (rs # r :: Vint n :: nil) m)
+     with (eval_operation ge sp Oshl (rs # r :: Vint i :: nil) m).
+  apply make_shlimm_correct. 
+  simpl. generalize (Int.is_power2_range _ _ H1). 
+  change (Z_of_nat wordsize) with 32. intro. rewrite H2.
+  destruct rs#r; auto. rewrite (Int.mul_pow2 i0 _ _ H1). auto.
+  exact H2.
+Qed.
+
+Lemma make_andimm_correct:
+  forall n r m v,
+  let (op, args) := make_andimm n r in
+  eval_operation ge sp Oand (rs#r :: Vint n :: nil) m = Some v ->
+  eval_operation ge sp op rs##args m = Some v.
+Proof.
+  intros; unfold make_andimm.
+  generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros.
+  subst n. simpl in *. FuncInv. rewrite Int.and_zero in H. congruence.
+  generalize (Int.eq_spec n Int.mone); case (Int.eq n Int.mone); intros.
+  subst n. simpl in *. FuncInv. rewrite Int.and_mone in H0. congruence.
+  exact H1.
+Qed.
+
+Lemma make_orimm_correct:
+  forall n r m v,
+  let (op, args) := make_orimm n r in
+  eval_operation ge sp Oor (rs#r :: Vint n :: nil) m = Some v ->
+  eval_operation ge sp op rs##args m = Some v.
+Proof.
+  intros; unfold make_orimm.
+  generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros.
+  subst n. simpl in *. FuncInv. rewrite Int.or_zero in H. congruence.
+  generalize (Int.eq_spec n Int.mone); case (Int.eq n Int.mone); intros.
+  subst n. simpl in *. FuncInv. rewrite Int.or_mone in H0. congruence.
+  exact H1.
+Qed.
+
+Lemma make_xorimm_correct:
+  forall n r m v,
+  let (op, args) := make_xorimm n r in
+  eval_operation ge sp Oxor (rs#r :: Vint n :: nil) m = Some v ->
+  eval_operation ge sp op rs##args m = Some v.
+Proof.
+  intros; unfold make_xorimm.
+  generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros.
+  subst n. simpl in *. FuncInv. rewrite Int.xor_zero in H. congruence.
+  exact H0.
+Qed.
+
+Lemma op_strength_reduction_correct:
+  forall op args m v,
+  let (op', args') := op_strength_reduction approx op args in
+  eval_operation ge sp op rs##args m = Some v ->
+  eval_operation ge sp op' rs##args' m = Some v.
+Proof.
+  intros; unfold op_strength_reduction;
+  case (op_strength_reduction_match op args); intros; simpl List.map.
+  (* Oadd *)
+  caseEq (intval approx r1); intros.
+  rewrite (intval_correct _ _ H). 
+  replace (eval_operation ge sp Oadd (Vint i :: rs # r2 :: nil) m)
+     with (eval_operation ge sp Oadd (rs # r2 :: Vint i :: nil) m).
+  apply make_addimm_correct. 
+  simpl. destruct rs#r2; auto. rewrite Int.add_commut; auto.
+  caseEq (intval approx r2); intros.
+  rewrite (intval_correct _ _ H0). apply make_addimm_correct.
+  assumption.
+  (* Osub *)
+  caseEq (intval approx r1); intros.
+  rewrite (intval_correct _ _ H) in H0. assumption. 
+  caseEq (intval approx r2); intros.
+  rewrite (intval_correct _ _ H0). 
+  replace (eval_operation ge sp Osub (rs # r1 :: Vint i :: nil) m)
+     with (eval_operation ge sp Oadd (rs # r1 :: Vint (Int.neg i) :: nil) m).
+  apply make_addimm_correct.
+  simpl. destruct rs#r1; auto; rewrite Int.sub_add_opp; auto. 
+  assumption.
+  (* Omul *)
+  caseEq (intval approx r1); intros.
+  rewrite (intval_correct _ _ H). 
+  replace (eval_operation ge sp Omul (Vint i :: rs # r2 :: nil) m)
+     with (eval_operation ge sp Omul (rs # r2 :: Vint i :: nil) m).
+  apply make_mulimm_correct. 
+  simpl. destruct rs#r2; auto. rewrite Int.mul_commut; auto.
+  caseEq (intval approx r2); intros.
+  rewrite (intval_correct _ _ H0). apply make_mulimm_correct.
+  assumption.
+  (* Odiv *)
+  caseEq (intval approx r2); intros.
+  caseEq (Int.is_power2 i); intros.
+  rewrite (intval_correct _ _ H) in H1.   
+  simpl in *; FuncInv. destruct (Int.eq i Int.zero). congruence.
+  change 32 with (Z_of_nat wordsize). 
+  rewrite (Int.is_power2_range _ _ H0). 
+  rewrite (Int.divs_pow2 i1 _ _ H0) in H1. auto.
+  assumption.
+  assumption.
+  (* Odivu *)
+  caseEq (intval approx r2); intros.
+  caseEq (Int.is_power2 i); intros.
+  rewrite (intval_correct _ _ H).
+  replace (eval_operation ge sp Odivu (rs # r1 :: Vint i :: nil) m)
+     with (eval_operation ge sp Oshru (rs # r1 :: Vint i0 :: nil) m).
+  apply make_shruimm_correct. 
+  simpl. destruct rs#r1; auto. 
+  change 32 with (Z_of_nat wordsize). 
+  rewrite (Int.is_power2_range _ _ H0). 
+  generalize (Int.eq_spec i Int.zero); case (Int.eq i Int.zero); intros.
+  subst i. discriminate. 
+  rewrite (Int.divu_pow2 i1 _ _ H0). auto.
+  assumption.
+  assumption.
+  (* Oand *)
+  caseEq (intval approx r1); intros.
+  rewrite (intval_correct _ _ H). 
+  replace (eval_operation ge sp Oand (Vint i :: rs # r2 :: nil) m)
+     with (eval_operation ge sp Oand (rs # r2 :: Vint i :: nil) m).
+  apply make_andimm_correct. 
+  simpl. destruct rs#r2; auto. rewrite Int.and_commut; auto.
+  caseEq (intval approx r2); intros.
+  rewrite (intval_correct _ _ H0). apply make_andimm_correct.
+  assumption.
+  (* Oor *)
+  caseEq (intval approx r1); intros.
+  rewrite (intval_correct _ _ H). 
+  replace (eval_operation ge sp Oor (Vint i :: rs # r2 :: nil) m)
+     with (eval_operation ge sp Oor (rs # r2 :: Vint i :: nil) m).
+  apply make_orimm_correct. 
+  simpl. destruct rs#r2; auto. rewrite Int.or_commut; auto.
+  caseEq (intval approx r2); intros.
+  rewrite (intval_correct _ _ H0). apply make_orimm_correct.
+  assumption.
+  (* Oxor *)
+  caseEq (intval approx r1); intros.
+  rewrite (intval_correct _ _ H). 
+  replace (eval_operation ge sp Oxor (Vint i :: rs # r2 :: nil) m)
+     with (eval_operation ge sp Oxor (rs # r2 :: Vint i :: nil) m).
+  apply make_xorimm_correct. 
+  simpl. destruct rs#r2; auto. rewrite Int.xor_commut; auto.
+  caseEq (intval approx r2); intros.
+  rewrite (intval_correct _ _ H0). apply make_xorimm_correct.
+  assumption.
+  (* Oshl *)
+  caseEq (intval approx r2); intros.
+  caseEq (Int.ltu i (Int.repr 32)); intros.
+  rewrite (intval_correct _ _ H). apply make_shlimm_correct.
+  assumption.
+  assumption.
+  (* Oshr *)
+  caseEq (intval approx r2); intros.
+  caseEq (Int.ltu i (Int.repr 32)); intros.
+  rewrite (intval_correct _ _ H). apply make_shrimm_correct.
+  assumption.
+  assumption.
+  (* Oshru *)
+  caseEq (intval approx r2); intros.
+  caseEq (Int.ltu i (Int.repr 32)); intros.
+  rewrite (intval_correct _ _ H). apply make_shruimm_correct.
+  assumption.
+  assumption.
+  (* Ocmp *)
+  generalize (cond_strength_reduction_correct c rl).
+  destruct (cond_strength_reduction approx c rl).
+  simpl. intro. rewrite H. auto.
+  (* default *)
+  assumption.
+Qed.
+
+Ltac KnownApprox :=
+  match goal with
+  | MATCH: (regs_match_approx ?approx ?rs),
+    H: (D.get ?r ?approx = ?a) |- _ =>
+      generalize (MATCH r); rewrite H; intro; clear H; KnownApprox
+  | _ => idtac
+  end.
+ 
+Lemma addr_strength_reduction_correct:
+  forall addr args,
+  let (addr', args') := addr_strength_reduction approx addr args in
+  eval_addressing ge sp addr' rs##args' = eval_addressing ge sp addr rs##args.
+Proof.
+  intros. 
+
+  (* Useful lemmas *)
+  assert (A0: forall r1 r2,
+    eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil)) =
+    eval_addressing ge sp Aindexed2 (rs ## (r2 :: r1 :: nil))).
+  intros. simpl. destruct (rs#r1); destruct (rs#r2); auto;
+  rewrite Int.add_commut; auto.
+
+  assert (A1: forall r1 r2 n,
+    val_match_approx (I n) rs#r2 -> 
+    eval_addressing ge sp (Aindexed n) (rs ## (r1 :: nil)) =
+    eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil))).
+  intros; simpl in *. rewrite H. auto.
+
+  assert (A2: forall r1 r2 n,
+    val_match_approx (I n) rs#r1 -> 
+    eval_addressing ge sp (Aindexed n) (rs ## (r2 :: nil)) =
+    eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil))).
+  intros. rewrite A0. apply A1. auto.
+
+  assert (A3: forall r1 r2 id ofs,
+    val_match_approx (S id ofs) rs#r1 ->
+    eval_addressing ge sp (Abased id ofs) (rs ## (r2 :: nil)) =
+    eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil))).
+  intros. elim H. intros b [A B]. simpl. rewrite A; rewrite B. auto.
+
+  assert (A4: forall r1 r2 id ofs,
+    val_match_approx (S id ofs) rs#r2 ->
+    eval_addressing ge sp (Abased id ofs) (rs ## (r1 :: nil)) =
+    eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil))).
+  intros. rewrite A0. apply A3. auto.
+
+  assert (A5: forall r1 r2 id ofs n,
+    val_match_approx (S id ofs) rs#r1 ->
+    val_match_approx (I n) rs#r2 ->
+    eval_addressing ge sp (Aglobal id (Int.add ofs n)) nil =
+    eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil))).
+  intros. elim H. intros b [A B]. simpl. rewrite A; rewrite B. 
+  simpl in H0. rewrite H0. auto.
+
+  unfold addr_strength_reduction;
+  case (addr_strength_reduction_match addr args); intros.
+
+  (* Aindexed2 *)
+  caseEq (D.get r1 approx); intros;
+  caseEq (D.get r2 approx); intros;
+  try reflexivity; KnownApprox; auto.
+  rewrite A0. rewrite Int.add_commut. apply A5; auto.
+
+  (* Abased *)
+  caseEq (intval approx r1); intros.
+  simpl; rewrite (intval_correct _ _ H). auto.
+  auto.
+
+  (* Aindexed *)
+  caseEq (D.get r1 approx); intros; auto.
+  simpl; KnownApprox. 
+  elim H0. intros b [A B]. rewrite A; rewrite B. auto.
+
+  (* default *)
+  reflexivity.
+Qed.
+
+End STRENGTH_REDUCTION.
+
+End ANALYSIS.
+
+(** * Correctness of the code transformation *)
+
+(** We now show that the transformed code after constant propagation
+  has the same semantics as the original code. *)
+
+Section PRESERVATION.
+
+Variable prog: program.
+Let tprog := transf_program prog.
+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.
+  intros; unfold ge, tge, tprog, transf_program. 
+  apply Genv.find_symbol_transf.
+Qed.
+
+Lemma functions_translated:
+  forall (v: val) (f: fundef),
+  Genv.find_funct ge v = Some f ->
+  Genv.find_funct tge v = Some (transf_fundef f).
+Proof.  
+  intros.
+  exact (Genv.find_funct_transf transf_fundef H).
+Qed.
+
+Lemma function_ptr_translated:
+  forall (b: block) (f: fundef),
+  Genv.find_funct_ptr ge b = Some f ->
+  Genv.find_funct_ptr tge b = Some (transf_fundef f).
+Proof.  
+  intros. 
+  exact (Genv.find_funct_ptr_transf transf_fundef H).
+Qed.
+
+Lemma sig_function_translated:
+  forall f,
+  funsig (transf_fundef f) = funsig f.
+Proof.
+  intros. destruct f; reflexivity.
+Qed.
+
+Lemma transf_ros_correct:
+  forall ros rs f approx,
+  regs_match_approx ge approx rs ->
+  find_function ge ros rs = Some f ->
+  find_function tge (transf_ros approx ros) rs = Some (transf_fundef f).
+Proof.
+  intros until approx; intro MATCH.
+  destruct ros; simpl.
+  intro.
+  exploit functions_translated; eauto. intro FIND.  
+  caseEq (D.get r approx); intros; auto.
+  generalize (Int.eq_spec i0 Int.zero); case (Int.eq i0 Int.zero); intros; auto.
+  generalize (MATCH r). rewrite H0. intros [b [A B]].
+  rewrite <- symbols_preserved in A.
+  rewrite B in FIND. rewrite H1 in FIND. 
+  rewrite Genv.find_funct_find_funct_ptr in FIND.
+  simpl. rewrite A. auto.
+  rewrite symbols_preserved. destruct (Genv.find_symbol ge i).
+  intro. apply function_ptr_translated. auto.
+  congruence.
+Qed.
+
+(** The proof of semantic preservation is a simulation argument
+  based on diagrams of the following form:
+<<
+           st1 --------------- st2
+            |                   |
+           t|                   |t
+            |                   |
+            v                   v
+           st1'--------------- st2'
+>>
+  The left vertical arrow represents a transition in the
+  original RTL code.  The top horizontal bar is the [match_states]
+  invariant between the initial state [st1] in the original RTL code
+  and an initial state [st2] in the transformed code.
+  This invariant expresses that all code fragments appearing in [st2]
+  are obtained by [transf_code] transformation of the corresponding
+  fragments in [st1].  Moreover, the values of registers in [st1]
+  must match their compile-time approximations at the current program
+  point.
+  These two parts of the diagram are the hypotheses.  In conclusions,
+  we want to prove the other two parts: the right vertical arrow,
+  which is a transition in the transformed RTL code, and the bottom
+  horizontal bar, which means that the [match_state] predicate holds
+  between the final states [st1'] and [st2']. *)
+
+Inductive match_stackframes: stackframe -> stackframe -> Prop :=
+   match_stackframe_intro:
+      forall res c sp pc rs f,
+      c = f.(RTL.fn_code) ->
+      (forall v, regs_match_approx ge (analyze f)!!pc (rs#res <- v)) ->
+    match_stackframes
+        (Stackframe res c sp pc rs)
+        (Stackframe res (transf_code (analyze f) c) sp pc rs).
+
+Inductive match_states: state -> state -> Prop :=
+  | match_states_intro:
+      forall s c sp pc rs m f s'
+           (CF: c = f.(RTL.fn_code))
+           (MATCH: regs_match_approx ge (analyze f)!!pc rs)
+           (STACKS: list_forall2 match_stackframes s s'),
+      match_states (State s c sp pc rs m)
+                   (State s' (transf_code (analyze f) c) sp pc rs m)
+  | match_states_call:
+      forall s f args m s',
+      list_forall2 match_stackframes s s' ->
+      match_states (Callstate s f args m)
+                   (Callstate s' (transf_fundef f) args m)
+  | match_states_return:
+      forall s s' v m,
+      list_forall2 match_stackframes s s' ->
+      match_states (Returnstate s v m)
+                   (Returnstate s' v m).
+
+Ltac TransfInstr :=
+  match goal with
+  | H1: (PTree.get ?pc ?c = Some ?instr), f: function |- _ =>
+      cut ((transf_code (analyze f) c)!pc = Some(transf_instr (analyze f)!!pc instr));
+      [ simpl
+      | unfold transf_code; rewrite PTree.gmap; 
+        unfold option_map; rewrite H1; reflexivity ]
+  end.
+
+(** The proof of simulation proceeds by case analysis on the transition
+  taken in the source code. *)
+
+Lemma transf_step_correct:
+  forall s1 t s2,
+  step ge s1 t s2 ->
+  forall s1' (MS: match_states s1 s1'),
+  exists s2', step tge s1' t s2' /\ match_states s2 s2'.
+Proof.
+  induction 1; intros; inv MS.
+
+  (* Inop *)
+  exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' rs m); split.
+  TransfInstr; intro. eapply exec_Inop; eauto.
+  econstructor; eauto.
+  eapply analyze_correct_1 with (pc := pc); eauto.
+  unfold successors; rewrite H; auto with coqlib.
+  unfold transfer; rewrite H. auto.
+
+  (* Iop *)
+  exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' (rs#res <- v) m); split.
+  TransfInstr. caseEq (op_strength_reduction (analyze f)!!pc op args);
+  intros op' args' OSR.
+  assert (eval_operation tge sp op' rs##args' m = Some v).
+    rewrite (eval_operation_preserved symbols_preserved). 
+    generalize (op_strength_reduction_correct ge (analyze f)!!pc sp rs
+                  MATCH op args m v).
+    rewrite OSR; simpl. auto.
+  generalize (eval_static_operation_correct ge op sp
+               (approx_regs args (analyze f)!!pc) rs##args m v
+               (approx_regs_val_list _ _ _ args MATCH) H0).
+  case (eval_static_operation op (approx_regs args (analyze f)!!pc)); intros;
+  simpl in H2;
+  eapply exec_Iop; eauto; simpl.
+  congruence.
+  congruence.
+  elim H2; intros b [A B]. rewrite symbols_preserved. 
+  rewrite A; rewrite B; auto.
+  econstructor; eauto. 
+  eapply analyze_correct_1 with (pc := pc); eauto.
+  unfold successors; rewrite H; auto with coqlib.
+  unfold transfer; rewrite H. 
+  apply regs_match_approx_update; auto. 
+  eapply eval_static_operation_correct; eauto.
+  apply approx_regs_val_list; auto.
+
+  (* Iload *)
+  caseEq (addr_strength_reduction (analyze f)!!pc addr args);
+  intros addr' args' ASR.
+  assert (eval_addressing tge sp addr' rs##args' = Some a).
+    rewrite (eval_addressing_preserved symbols_preserved). 
+    generalize (addr_strength_reduction_correct ge (analyze f)!!pc sp rs
+                  MATCH addr args).
+    rewrite ASR; simpl. congruence. 
+  TransfInstr. rewrite ASR. intro.
+  exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' (rs#dst <- v) m); split.
+  eapply exec_Iload; eauto.
+  econstructor; eauto. 
+  apply analyze_correct_1 with pc; auto. 
+  unfold successors; rewrite H; auto with coqlib.
+  unfold transfer; rewrite H. 
+  apply regs_match_approx_update; auto. simpl; auto.
+
+  (* Istore *)
+  caseEq (addr_strength_reduction (analyze f)!!pc addr args);
+  intros addr' args' ASR.
+  assert (eval_addressing tge sp addr' rs##args' = Some a).
+    rewrite (eval_addressing_preserved symbols_preserved). 
+    generalize (addr_strength_reduction_correct ge (analyze f)!!pc sp rs
+                  MATCH addr args).
+    rewrite ASR; simpl. congruence. 
+  TransfInstr. rewrite ASR. intro.
+  exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' rs m'); split.
+  eapply exec_Istore; eauto.
+  econstructor; eauto. 
+  apply analyze_correct_1 with pc; auto. 
+  unfold successors; rewrite H; auto with coqlib.
+  unfold transfer; rewrite H. auto. 
+
+  (* Icall *)
+  exploit transf_ros_correct; eauto. intro FIND'.
+  TransfInstr; intro.
+  econstructor; split.
+  eapply exec_Icall; eauto. apply sig_function_translated; auto.
+  constructor; auto. constructor; auto.
+  econstructor; eauto. 
+  intros. apply analyze_correct_1 with pc; auto.
+  unfold successors; rewrite H; auto with coqlib.
+  unfold transfer; rewrite H.
+  apply regs_match_approx_update; auto. simpl. auto.
+
+  (* Itailcall *)
+  exploit transf_ros_correct; eauto. intros FIND'.
+  TransfInstr; intro.
+  econstructor; split.
+  eapply exec_Itailcall; eauto. apply sig_function_translated; auto.
+  constructor; auto. 
+
+  (* Ialloc *)
+  TransfInstr; intro.
+  exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' (rs#res <- (Vptr b Int.zero)) m'); split.
+  eapply exec_Ialloc; eauto.
+  econstructor; eauto.
+  apply analyze_correct_1 with pc; auto. 
+  unfold successors; rewrite H; auto with coqlib.
+  unfold transfer; rewrite H. 
+  apply regs_match_approx_update; auto. simpl; auto.
+
+  (* Icond, true *)
+  exists (State s' (transf_code (analyze f) (fn_code f)) sp ifso rs m); split. 
+  caseEq (cond_strength_reduction (analyze f)!!pc cond args);
+  intros cond' args' CSR.
+  assert (eval_condition cond' rs##args' m = Some true).
+    generalize (cond_strength_reduction_correct
+                  ge (analyze f)!!pc rs MATCH cond args m).
+    rewrite CSR.  intro. congruence.
+  TransfInstr. rewrite CSR. 
+  caseEq (eval_static_condition cond (approx_regs args (analyze f)!!pc)).
+  intros b ESC. 
+  generalize (eval_static_condition_correct ge cond _ _ m _
+               (approx_regs_val_list _ _ _ args MATCH) ESC); intro.
+  replace b with true. intro; eapply exec_Inop; eauto. congruence.
+  intros. eapply exec_Icond_true; eauto.
+  econstructor; eauto.
+  apply analyze_correct_1 with pc; auto. 
+  unfold successors; rewrite H; auto with coqlib.
+  unfold transfer; rewrite H; auto.
+
+  (* Icond, false *)
+  exists (State s' (transf_code (analyze f) (fn_code f)) sp ifnot rs m); split. 
+  caseEq (cond_strength_reduction (analyze f)!!pc cond args);
+  intros cond' args' CSR.
+  assert (eval_condition cond' rs##args' m = Some false).
+    generalize (cond_strength_reduction_correct
+                  ge (analyze f)!!pc rs MATCH cond args m).
+    rewrite CSR.  intro. congruence.
+  TransfInstr. rewrite CSR. 
+  caseEq (eval_static_condition cond (approx_regs args (analyze f)!!pc)).
+  intros b ESC. 
+  generalize (eval_static_condition_correct ge cond _ _ m _
+               (approx_regs_val_list _ _ _ args MATCH) ESC); intro.
+  replace b with false. intro; eapply exec_Inop; eauto. congruence.
+  intros. eapply exec_Icond_false; eauto.
+  econstructor; eauto.
+  apply analyze_correct_1 with pc; auto. 
+  unfold successors; rewrite H; auto with coqlib.
+  unfold transfer; rewrite H; auto.
+
+  (* Ireturn *)
+  exists (Returnstate s' (regmap_optget or Vundef rs) (free m stk)); split.
+  eapply exec_Ireturn; eauto. TransfInstr; auto.
+  constructor; auto.
+
+  (* internal function *)
+  simpl. unfold transf_function.
+  econstructor; split.
+  eapply exec_function_internal; simpl; eauto.
+  simpl. econstructor; eauto.
+  apply analyze_correct_3; auto.
+
+  (* external function *)
+  simpl. econstructor; split.
+  eapply exec_function_external; eauto.
+  constructor; auto.
+
+  (* return *)
+  inv H3. inv H1. 
+  econstructor; split.
+  eapply exec_return; eauto. 
+  econstructor; eauto. 
+Qed.
+
+Lemma transf_initial_states:
+  forall st1, initial_state prog st1 ->
+  exists st2, initial_state tprog st2 /\ match_states st1 st2.
+Proof.
+  intros. inversion H.
+  exploit function_ptr_translated; eauto. intro FIND.
+  exists (Callstate nil (transf_fundef f) nil (Genv.init_mem tprog)); split.
+  econstructor; eauto.
+  replace (prog_main tprog) with (prog_main prog).
+  rewrite symbols_preserved. eauto.
+  reflexivity.
+  rewrite <- H2. apply sig_function_translated.
+  replace (Genv.init_mem tprog) with (Genv.init_mem prog).
+  constructor. constructor. auto.
+  symmetry. unfold tprog, transf_program. apply Genv.init_mem_transf. 
+Qed.
+
+Lemma transf_final_states:
+  forall st1 st2 r, 
+  match_states st1 st2 -> final_state st1 r -> final_state st2 r.
+Proof.
+  intros. inv H0. inv H. inv H4. constructor. 
+Qed.
+
+(** The preservation of the observable behavior of the program then
+  follows, using the generic preservation theorem
+  [Smallstep.simulation_step_preservation]. *)
+
+Theorem transf_program_correct:
+  forall (beh: program_behavior),
+  exec_program prog beh -> exec_program tprog beh.
+Proof.
+  unfold exec_program; intros.
+  eapply simulation_step_preservation; eauto.
+  eexact transf_initial_states.
+  eexact transf_final_states.
+  exact transf_step_correct. 
+Qed.
+
+End PRESERVATION.
diff --git a/powerpc/Machregs.v b/powerpc/Machregs.v
new file mode 100644
index 00000000..260a0e85
--- /dev/null
+++ b/powerpc/Machregs.v
@@ -0,0 +1,107 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              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.     *)
+(*                                                                     *)
+(* *********************************************************************)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import AST.
+
+(** ** Machine registers *)
+
+(** The following type defines the machine registers that can be referenced
+  as locations.  These include:
+- Integer registers that can be allocated to RTL pseudo-registers ([Rxx]).
+- Floating-point registers that can be allocated to RTL pseudo-registers 
+  ([Fxx]).
+- Two integer registers, not allocatable, reserved as temporaries for
+  spilling and reloading ([IT1, IT2]).
+- Two float registers, not allocatable, reserved as temporaries for
+  spilling and reloading ([FT1, FT2]).
+
+  The type [mreg] does not include special-purpose machine registers
+  such as the stack pointer and the condition codes. *)
+
+Inductive mreg: Set :=
+  (** Allocatable integer regs *)
+  | R3: mreg  | R4: mreg  | R5: mreg  | R6: mreg
+  | R7: mreg  | R8: mreg  | R9: mreg  | R10: mreg
+  | R13: mreg | R14: mreg | R15: mreg | R16: mreg
+  | R17: mreg | R18: mreg | R19: mreg | R20: mreg
+  | R21: mreg | R22: mreg | R23: mreg | R24: mreg
+  | R25: mreg | R26: mreg | R27: mreg | R28: mreg
+  | R29: mreg | R30: mreg | R31: mreg
+  (** Allocatable float regs *)
+  | F1: mreg  | F2: mreg  | F3: mreg  | F4: mreg
+  | F5: mreg  | F6: mreg  | F7: mreg  | F8: mreg
+  | F9: mreg  | F10: mreg | F14: mreg | F15: mreg
+  | F16: mreg | F17: mreg | F18: mreg | F19: mreg
+  | F20: mreg | F21: mreg | F22: mreg | F23: mreg
+  | F24: mreg | F25: mreg | F26: mreg | F27: mreg
+  | F28: mreg | F29: mreg | F30: mreg | F31: mreg
+  (** Integer temporaries *)
+  | IT1: mreg (* R11 *) | IT2: mreg (* R0 *)
+  (** Float temporaries *)
+  | FT1: mreg (* F11 *) | FT2: mreg (* F12 *) | FT3: mreg (* F0 *).
+
+Lemma mreg_eq: forall (r1 r2: mreg), {r1 = r2} + {r1 <> r2}.
+Proof. decide equality. Qed.
+
+Definition mreg_type (r: mreg): typ :=
+  match r with
+  | R3 => Tint  | R4 => Tint  | R5 => Tint  | R6 => Tint
+  | R7 => Tint  | R8 => Tint  | R9 => Tint  | R10 => Tint
+  | R13 => Tint | R14 => Tint | R15 => Tint | R16 => Tint
+  | R17 => Tint | R18 => Tint | R19 => Tint | R20 => Tint
+  | R21 => Tint | R22 => Tint | R23 => Tint | R24 => Tint
+  | R25 => Tint | R26 => Tint | R27 => Tint | R28 => Tint
+  | R29 => Tint | R30 => Tint | R31 => Tint
+  | F1 => Tfloat  | F2 => Tfloat  | F3 => Tfloat  | F4 => Tfloat
+  | F5 => Tfloat  | F6 => Tfloat  | F7 => Tfloat  | F8 => Tfloat
+  | F9 => Tfloat  | F10 => Tfloat | F14 => Tfloat | F15 => Tfloat
+  | F16 => Tfloat | F17 => Tfloat | F18 => Tfloat | F19 => Tfloat
+  | F20 => Tfloat | F21 => Tfloat | F22 => Tfloat | F23 => Tfloat
+  | F24 => Tfloat | F25 => Tfloat | F26 => Tfloat | F27 => Tfloat
+  | F28 => Tfloat | F29 => Tfloat | F30 => Tfloat | F31 => Tfloat
+  | IT1 => Tint | IT2 => Tint
+  | FT1 => Tfloat | FT2 => Tfloat | FT3 => Tfloat
+  end.
+
+Open Scope positive_scope.
+
+Module IndexedMreg <: INDEXED_TYPE.
+  Definition t := mreg.
+  Definition eq := mreg_eq.
+  Definition index (r: mreg): positive :=
+    match r with
+    | R3 => 1  | R4 => 2  | R5 => 3  | R6 => 4
+    | R7 => 5  | R8 => 6  | R9 => 7  | R10 => 8
+    | R13 => 9 | R14 => 10 | R15 => 11 | R16 => 12
+    | R17 => 13 | R18 => 14 | R19 => 15 | R20 => 16
+    | R21 => 17 | R22 => 18 | R23 => 19 | R24 => 20
+    | R25 => 21 | R26 => 22 | R27 => 23 | R28 => 24
+    | R29 => 25 | R30 => 26 | R31 => 27
+    | F1 => 28  | F2 => 29  | F3 => 30  | F4 => 31
+    | F5 => 32  | F6 => 33  | F7 => 34  | F8 => 35
+    | F9 => 36  | F10 => 37 | F14 => 38 | F15 => 39
+    | F16 => 40 | F17 => 41 | F18 => 42 | F19 => 43
+    | F20 => 44 | F21 => 45 | F22 => 46 | F23 => 47
+    | F24 => 48 | F25 => 49 | F26 => 50 | F27 => 51
+    | F28 => 52 | F29 => 53 | F30 => 54 | F31 => 55
+    | IT1 => 56 | IT2 => 57
+    | FT1 => 58 | FT2 => 59 | FT3 => 60
+    end.
+  Lemma index_inj:
+    forall r1 r2, index r1 = index r2 -> r1 = r2.
+  Proof.
+    destruct r1; destruct r2; simpl; intro; discriminate || reflexivity.
+  Qed.
+End IndexedMreg.
+
diff --git a/powerpc/Op.v b/powerpc/Op.v
new file mode 100644
index 00000000..20ebf705
--- /dev/null
+++ b/powerpc/Op.v
@@ -0,0 +1,925 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              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.     *)
+(*                                                                     *)
+(* *********************************************************************)
+
+(** Operators and addressing modes.  The abstract syntax and dynamic
+  semantics for the CminorSel, RTL, LTL and Mach languages depend on the
+  following types, defined in this library:
+- [condition]:  boolean conditions for conditional branches;
+- [operation]: arithmetic and logical operations;
+- [addressing]: addressing modes for load and store operations.
+
+  These types are PowerPC-specific and correspond roughly to what the 
+  processor can compute in one instruction.  In other terms, these
+  types reflect the state of the program after instruction selection.
+  For a processor-independent set of operations, see the abstract
+  syntax and dynamic semantics of the Cminor language.
+*)
+
+Require Import Coqlib.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Mem.
+Require Import Globalenvs.
+
+Set Implicit Arguments.
+
+(** Conditions (boolean-valued operators). *)
+
+Inductive condition : Set :=
+  | Ccomp: comparison -> condition      (**r signed integer comparison *)
+  | Ccompu: comparison -> condition     (**r unsigned integer comparison *)
+  | Ccompimm: comparison -> int -> condition (**r signed integer comparison with a constant *)
+  | Ccompuimm: comparison -> int -> condition  (**r unsigned integer comparison with a constant *)
+  | Ccompf: comparison -> condition     (**r floating-point comparison *)
+  | Cnotcompf: comparison -> condition  (**r negation of a floating-point comparison *)
+  | Cmaskzero: int -> condition         (**r test [(arg & constant) == 0] *)
+  | Cmasknotzero: int -> condition.     (**r test [(arg & constant) != 0] *)
+
+(** Arithmetic and logical operations.  In the descriptions, [rd] is the
+  result of the operation and [r1], [r2], etc, are the arguments. *)
+
+Inductive operation : Set :=
+  | Omove: operation                    (**r [rd = r1] *)
+  | Ointconst: int -> operation         (**r [rd] is set to the given integer constant *)
+  | Ofloatconst: float -> operation     (**r [rd] is set to the given float constant *)
+  | Oaddrsymbol: ident -> int -> operation (**r [rd] is set to the the address of the symbol plus the offset *)
+  | Oaddrstack: int -> operation        (**r [rd] is set to the stack pointer plus the given offset *)
+(*c Integer arithmetic: *)
+  | Ocast8signed: operation             (**r [rd] is 8-bit sign extension of [r1] *)
+  | Ocast8unsigned: operation           (**r [rd] is 8-bit zero extension of [r1] *)
+  | Ocast16signed: operation            (**r [rd] is 16-bit sign extension of [r1] *)
+  | Ocast16unsigned: operation          (**r [rd] is 16-bit zero extension of [r1] *)
+  | Oadd: operation                     (**r [rd = r1 + r2] *)
+  | Oaddimm: int -> operation           (**r [rd = r1 + n] *)
+  | Osub: operation                     (**r [rd = r1 - r2] *)
+  | Osubimm: int -> operation           (**r [rd = n - r1] *)
+  | Omul: operation                     (**r [rd = r1 * r2] *)
+  | Omulimm: int -> operation           (**r [rd = r1 * n] *)
+  | Odiv: operation                     (**r [rd = r1 / r2] (signed) *)
+  | Odivu: operation                    (**r [rd = r1 / r2] (unsigned) *)
+  | Oand: operation                     (**r [rd = r1 & r2] *)
+  | Oandimm: int -> operation           (**r [rd = r1 & n] *)
+  | Oor: operation                      (**r [rd = r1 | r2] *)
+  | Oorimm: int -> operation            (**r [rd = r1 | n] *)
+  | Oxor: operation                     (**r [rd = r1 ^ r2] *)
+  | Oxorimm: int -> operation           (**r [rd = r1 ^ n] *)
+  | Onand: operation                    (**r [rd = ~(r1 & r2)] *)
+  | Onor: operation                     (**r [rd = ~(r1 | r2)] *)
+  | Onxor: operation                    (**r [rd = ~(r1 ^ r2)] *)
+  | Oshl: operation                     (**r [rd = r1 << r2] *)
+  | Oshr: operation                     (**r [rd = r1 >> r2] (signed) *)
+  | Oshrimm: int -> operation           (**r [rd = r1 >> n] (signed) *)
+  | Oshrximm: int -> operation          (**r [rd = r1 / 2^n] (signed) *)
+  | Oshru: operation                    (**r [rd = r1 >> r2] (unsigned) *)
+  | Orolm: int -> int -> operation      (**r rotate left and mask *)
+(*c Floating-point arithmetic: *)
+  | Onegf: operation                    (**r [rd = - r1] *)
+  | Oabsf: operation                    (**r [rd = abs(r1)] *)
+  | Oaddf: operation                    (**r [rd = r1 + r2] *)
+  | Osubf: operation                    (**r [rd = r1 - r2] *)
+  | Omulf: operation                    (**r [rd = r1 * r2] *)
+  | Odivf: operation                    (**r [rd = r1 / r2] *)
+  | Omuladdf: operation                 (**r [rd = r1 * r2 + r3] *)
+  | Omulsubf: operation                 (**r [rd = r1 * r2 - r3] *)
+  | Osingleoffloat: operation           (**r [rd] is [r1] truncated to single-precision float *)
+(*c Conversions between int and float: *)
+  | Ointoffloat: operation              (**r [rd = signed_int_of_float(r1)] *)
+  | Ointuoffloat: operation             (**r [rd = unsigned_int_of_float(r1)] *)
+  | Ofloatofint: operation              (**r [rd = float_of_signed_int(r1)] *)
+  | Ofloatofintu: operation             (**r [rd = float_of_unsigned_int(r1)] *)
+(*c Boolean tests: *)
+  | Ocmp: condition -> operation.       (**r [rd = 1] if condition holds, [rd = 0] otherwise. *)
+
+(** Addressing modes.  [r1], [r2], etc, are the arguments to the 
+  addressing. *)
+
+Inductive addressing: Set :=
+  | Aindexed: int -> addressing         (**r Address is [r1 + offset] *)
+  | Aindexed2: addressing               (**r Address is [r1 + r2] *)
+  | Aglobal: ident -> int -> addressing (**r Address is [symbol + offset] *)
+  | Abased: ident -> int -> addressing (**r Address is [symbol + offset + r1] *)
+  | Ainstack: int -> addressing.        (**r Address is [stack_pointer + offset] *)
+
+(** Comparison functions (used in module [CSE]). *)
+
+Definition eq_operation (x y: operation): {x=y} + {x<>y}.
+Proof.
+  generalize Int.eq_dec; intro.
+  generalize Float.eq_dec; intro.
+  assert (forall (x y: ident), {x=y}+{x<>y}). exact peq.
+  assert (forall (x y: comparison), {x=y}+{x<>y}). decide equality.
+  assert (forall (x y: condition), {x=y}+{x<>y}). decide equality.
+  decide equality.
+Qed.
+
+Definition eq_addressing (x y: addressing) : {x=y} + {x<>y}.
+Proof.
+  generalize Int.eq_dec; intro.
+  assert (forall (x y: ident), {x=y}+{x<>y}). exact peq.
+  decide equality.
+Qed.
+
+(** Evaluation of conditions, operators and addressing modes applied
+  to lists of values.  Return [None] when the computation is undefined:
+  wrong number of arguments, arguments of the wrong types, undefined 
+  operations such as division by zero.  [eval_condition] returns a boolean,
+  [eval_operation] and [eval_addressing] return a value. *)
+
+Definition eval_compare_mismatch (c: comparison) : option bool :=
+  match c with Ceq => Some false | Cne => Some true | _ => None end.
+
+Definition eval_condition (cond: condition) (vl: list val) (m: mem):
+               option bool :=
+  match cond, vl with
+  | Ccomp c, Vint n1 :: Vint n2 :: nil =>
+      Some (Int.cmp c n1 n2)
+  | Ccomp c, Vptr b1 n1 :: Vptr b2 n2 :: nil =>
+      if valid_pointer m b1 (Int.signed n1)
+      && valid_pointer m b2 (Int.signed n2) then
+        if eq_block b1 b2
+        then Some (Int.cmp c n1 n2)
+        else eval_compare_mismatch c
+      else None
+  | Ccomp c, Vptr b1 n1 :: Vint n2 :: nil =>
+      if Int.eq n2 Int.zero then eval_compare_mismatch c else None
+  | Ccomp c, Vint n1 :: Vptr b2 n2 :: nil =>
+      if Int.eq n1 Int.zero then eval_compare_mismatch c else None
+  | Ccompu c, Vint n1 :: Vint n2 :: nil =>
+      Some (Int.cmpu c n1 n2)
+  | Ccompimm c n, Vint n1 :: nil =>
+      Some (Int.cmp c n1 n)
+  | Ccompimm c n, Vptr b1 n1 :: nil =>
+      if Int.eq n Int.zero then eval_compare_mismatch c else None
+  | Ccompuimm c n, Vint n1 :: nil =>
+      Some (Int.cmpu c n1 n)
+  | Ccompf c, Vfloat f1 :: Vfloat f2 :: nil =>
+      Some (Float.cmp c f1 f2)
+  | Cnotcompf c, Vfloat f1 :: Vfloat f2 :: nil =>
+      Some (negb (Float.cmp c f1 f2))
+  | Cmaskzero n, Vint n1 :: nil =>
+      Some (Int.eq (Int.and n1 n) Int.zero)
+  | Cmasknotzero n, Vint n1 :: nil =>
+      Some (negb (Int.eq (Int.and n1 n) Int.zero))
+  | _, _ =>
+      None
+  end.
+
+Definition offset_sp (sp: val) (delta: int) : option val :=
+  match sp with
+  | Vptr b n => Some (Vptr b (Int.add n delta))
+  | _ => None
+  end.
+
+Definition eval_operation
+    (F: Set) (genv: Genv.t F) (sp: val)
+    (op: operation) (vl: list val) (m: mem): option val :=
+  match op, vl with
+  | Omove, v1::nil => Some v1
+  | Ointconst n, nil => Some (Vint n)
+  | Ofloatconst n, nil => Some (Vfloat n)
+  | Oaddrsymbol s ofs, nil =>
+      match Genv.find_symbol genv s with
+      | None => None
+      | Some b => Some (Vptr b ofs)
+      end
+  | Oaddrstack ofs, nil => offset_sp sp ofs
+  | Ocast8signed, v1 :: nil => Some (Val.sign_ext 8 v1)
+  | Ocast8unsigned, v1 :: nil => Some (Val.zero_ext 8 v1)
+  | Ocast16signed, v1 :: nil => Some (Val.sign_ext 16 v1)
+  | Ocast16unsigned, v1 :: nil => Some (Val.zero_ext 16 v1)
+  | Oadd, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.add n1 n2))
+  | Oadd, Vint n1 :: Vptr b2 n2 :: nil => Some (Vptr b2 (Int.add n2 n1))
+  | Oadd, Vptr b1 n1 :: Vint n2 :: nil => Some (Vptr b1 (Int.add n1 n2))
+  | Oaddimm n, Vint n1 :: nil => Some (Vint (Int.add n1 n))
+  | Oaddimm n, Vptr b1 n1 :: nil => Some (Vptr b1 (Int.add n1 n))
+  | Osub, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.sub n1 n2))
+  | Osub, Vptr b1 n1 :: Vint n2 :: nil => Some (Vptr b1 (Int.sub n1 n2))
+  | Osub, Vptr b1 n1 :: Vptr b2 n2 :: nil =>
+      if eq_block b1 b2 then Some (Vint (Int.sub n1 n2)) else None
+  | Osubimm n, Vint n1 :: nil => Some (Vint (Int.sub n n1))
+  | Omul, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.mul n1 n2))
+  | Omulimm n, Vint n1 :: nil => Some (Vint (Int.mul n1 n))
+  | Odiv, Vint n1 :: Vint n2 :: nil =>
+      if Int.eq n2 Int.zero then None else Some (Vint (Int.divs n1 n2))
+  | Odivu, Vint n1 :: Vint n2 :: nil =>
+      if Int.eq n2 Int.zero then None else Some (Vint (Int.divu n1 n2))
+  | Oand, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.and n1 n2))
+  | Oandimm n, Vint n1 :: nil => Some (Vint (Int.and n1 n))
+  | Oor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.or n1 n2))
+  | Oorimm n, Vint n1 :: nil => Some (Vint (Int.or n1 n))
+  | Oxor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.xor n1 n2))
+  | Oxorimm n, Vint n1 :: nil => Some (Vint (Int.xor n1 n))
+  | Onand, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.not (Int.and n1 n2)))
+  | Onor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.not (Int.or n1 n2)))
+  | Onxor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.not (Int.xor n1 n2)))
+  | Oshl, Vint n1 :: Vint n2 :: nil =>
+      if Int.ltu n2 (Int.repr 32) then Some (Vint (Int.shl n1 n2)) else None
+  | Oshr, Vint n1 :: Vint n2 :: nil =>
+      if Int.ltu n2 (Int.repr 32) then Some (Vint (Int.shr n1 n2)) else None
+  | Oshrimm n, Vint n1 :: nil =>
+      if Int.ltu n (Int.repr 32) then Some (Vint (Int.shr n1 n)) else None
+  | Oshrximm n, Vint n1 :: nil =>
+      if Int.ltu n (Int.repr 32) then Some (Vint (Int.shrx n1 n)) else None
+  | Oshru, Vint n1 :: Vint n2 :: nil =>
+      if Int.ltu n2 (Int.repr 32) then Some (Vint (Int.shru n1 n2)) else None
+  | Orolm amount mask, Vint n1 :: nil =>
+      Some (Vint (Int.rolm n1 amount mask))
+  | Onegf, Vfloat f1 :: nil => Some (Vfloat (Float.neg f1))
+  | Oabsf, Vfloat f1 :: nil => Some (Vfloat (Float.abs f1))
+  | Oaddf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.add f1 f2))
+  | Osubf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.sub f1 f2))
+  | Omulf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.mul f1 f2))
+  | Odivf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.div f1 f2))
+  | Omuladdf, Vfloat f1 :: Vfloat f2 :: Vfloat f3 :: nil =>
+      Some (Vfloat (Float.add (Float.mul f1 f2) f3))
+  | Omulsubf, Vfloat f1 :: Vfloat f2 :: Vfloat f3 :: nil =>
+      Some (Vfloat (Float.sub (Float.mul f1 f2) f3))
+  | Osingleoffloat, v1 :: nil =>
+      Some (Val.singleoffloat v1)
+  | Ointoffloat, Vfloat f1 :: nil => 
+      Some (Vint (Float.intoffloat f1))
+  | Ointuoffloat, Vfloat f1 :: nil => 
+      Some (Vint (Float.intuoffloat f1))
+  | Ofloatofint, Vint n1 :: nil => 
+      Some (Vfloat (Float.floatofint n1))
+  | Ofloatofintu, Vint n1 :: nil => 
+      Some (Vfloat (Float.floatofintu n1))
+  | Ocmp c, _ =>
+      match eval_condition c vl m with
+      | None => None
+      | Some false => Some Vfalse
+      | Some true => Some Vtrue
+      end
+  | _, _ => None
+  end.
+
+Definition eval_addressing
+    (F: Set) (genv: Genv.t F) (sp: val)
+    (addr: addressing) (vl: list val) : option val :=
+  match addr, vl with
+  | Aindexed n, Vptr b1 n1 :: nil =>
+      Some (Vptr b1 (Int.add n1 n))
+  | Aindexed2, Vptr b1 n1 :: Vint n2 :: nil =>
+      Some (Vptr b1 (Int.add n1 n2))
+  | Aindexed2, Vint n1 :: Vptr b2 n2 :: nil =>
+      Some (Vptr b2 (Int.add n2 n1))
+  | Aglobal s ofs, nil =>
+      match Genv.find_symbol genv s with
+      | None => None
+      | Some b => Some (Vptr b ofs)
+      end
+  | Abased s ofs, Vint n1 :: nil =>
+      match Genv.find_symbol genv s with
+      | None => None
+      | Some b => Some (Vptr b (Int.add ofs n1))
+      end
+  | Ainstack ofs, nil =>
+      offset_sp sp ofs
+  | _, _ => None
+  end.
+
+Definition negate_condition (cond: condition): condition :=
+  match cond with
+  | Ccomp c => Ccomp(negate_comparison c)
+  | Ccompu c => Ccompu(negate_comparison c)
+  | Ccompimm c n => Ccompimm (negate_comparison c) n
+  | Ccompuimm c n => Ccompuimm (negate_comparison c) n
+  | Ccompf c => Cnotcompf c
+  | Cnotcompf c => Ccompf c
+  | Cmaskzero n => Cmasknotzero n
+  | Cmasknotzero n => Cmaskzero n
+  end.
+
+Ltac FuncInv :=
+  match goal with
+  | H: (match ?x with nil => _ | _ :: _ => _ end = Some _) |- _ =>
+      destruct x; simpl in H; try discriminate; FuncInv
+  | H: (match ?v with Vundef => _ | Vint _ => _ | Vfloat _ => _ | Vptr _ _ => _ end = Some _) |- _ =>
+      destruct v; simpl in H; try discriminate; FuncInv
+  | H: (Some _ = Some _) |- _ =>
+      injection H; intros; clear H; FuncInv
+  | _ =>
+      idtac
+  end.
+
+Remark eval_negate_compare_mismatch:
+  forall c b,
+  eval_compare_mismatch c = Some b ->
+  eval_compare_mismatch (negate_comparison c) = Some (negb b).
+Proof.
+  intros until b. unfold eval_compare_mismatch.
+  destruct c; intro EQ; inv EQ; auto. 
+Qed.
+
+Lemma eval_negate_condition:
+  forall (cond: condition) (vl: list val) (b: bool) (m: mem),
+  eval_condition cond vl m = Some b ->
+  eval_condition (negate_condition cond) vl m = Some (negb b).
+Proof.
+  intros. 
+  destruct cond; simpl in H; FuncInv; try subst b; simpl.
+  rewrite Int.negate_cmp. auto.
+  destruct (Int.eq i Int.zero). apply eval_negate_compare_mismatch; auto. discriminate.
+  destruct (Int.eq i0 Int.zero). apply eval_negate_compare_mismatch; auto. discriminate.
+  destruct (valid_pointer m b0 (Int.signed i) &&
+            valid_pointer m b1 (Int.signed i0)).
+  destruct (eq_block b0 b1). rewrite Int.negate_cmp. congruence.
+  apply eval_negate_compare_mismatch; auto. 
+  discriminate.
+  rewrite Int.negate_cmpu. auto.
+  rewrite Int.negate_cmp. auto.
+  destruct (Int.eq i Int.zero). apply eval_negate_compare_mismatch; auto. discriminate.
+  rewrite Int.negate_cmpu. auto.
+  auto.
+  rewrite negb_elim. auto.
+  auto.
+  rewrite negb_elim. auto.
+Qed.
+
+(** [eval_operation] and [eval_addressing] depend on a global environment
+  for resolving references to global symbols.  We show that they give
+  the same results if a global environment is replaced by another that
+  assigns the same addresses to the same symbols. *)
+
+Section GENV_TRANSF.
+
+Variable F1 F2: Set.
+Variable ge1: Genv.t F1.
+Variable ge2: Genv.t F2.
+Hypothesis agree_on_symbols:
+  forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s.
+
+Lemma eval_operation_preserved:
+  forall sp op vl m,
+  eval_operation ge2 sp op vl m = eval_operation ge1 sp op vl m.
+Proof.
+  intros.
+  unfold eval_operation; destruct op; try rewrite agree_on_symbols;
+  reflexivity.
+Qed.
+
+Lemma eval_addressing_preserved:
+  forall sp addr vl,
+  eval_addressing ge2 sp addr vl = eval_addressing ge1 sp addr vl.
+Proof.
+  intros.
+  unfold eval_addressing; destruct addr; try rewrite agree_on_symbols;
+  reflexivity.
+Qed.
+
+End GENV_TRANSF.
+
+(** [eval_condition] and [eval_operation] depend on a memory store
+    (to check pointer validity in pointer comparisons).
+    We show that their results are preserved by a change of
+    memory if this change preserves pointer validity.
+    In particular, this holds in case of a memory allocation
+    or a memory store. *)
+
+Lemma eval_condition_change_mem:
+  forall m m' c args b,
+  (forall b ofs, valid_pointer m b ofs = true -> valid_pointer m' b ofs = true) ->
+  eval_condition c args m = Some b -> eval_condition c args m' = Some b.
+Proof.
+  intros until b. intro INV. destruct c; simpl; auto.
+  destruct args; auto. destruct v; auto. destruct args; auto.
+  destruct v; auto. destruct args; auto. 
+  caseEq (valid_pointer m b0 (Int.signed i)); intro.
+  caseEq (valid_pointer m b1 (Int.signed i0)); intro.
+  simpl. rewrite (INV _ _ H). rewrite (INV _ _ H0). auto.
+  simpl; congruence. simpl; congruence.
+Qed.
+
+Lemma eval_operation_change_mem:
+  forall (F: Set) m m' (ge: Genv.t F) sp op args v,
+  (forall b ofs, valid_pointer m b ofs = true -> valid_pointer m' b ofs = true) ->
+  eval_operation ge sp op args m = Some v -> eval_operation ge sp op args m' = Some v.
+Proof.
+  intros until v; intro INV. destruct op; simpl; auto.
+  caseEq (eval_condition c args m); intros.
+  rewrite (eval_condition_change_mem _ _ _ _ INV H). auto.
+  discriminate.
+Qed.
+
+Lemma eval_condition_alloc:
+  forall m lo hi m' b c args v,
+  Mem.alloc m lo hi = (m', b) ->
+  eval_condition c args m = Some v -> eval_condition c args m' = Some v.
+Proof.
+  intros. apply eval_condition_change_mem with m; auto.
+  intros. eapply valid_pointer_alloc; eauto.
+Qed.
+
+Lemma eval_operation_alloc:
+  forall (F: Set) m lo hi m' b (ge: Genv.t F) sp op args v,
+  Mem.alloc m lo hi = (m', b) ->
+  eval_operation ge sp op args m = Some v -> eval_operation ge sp op args m' = Some v.
+Proof.
+  intros. apply eval_operation_change_mem with m; auto.
+  intros. eapply valid_pointer_alloc; eauto.
+Qed.
+
+Lemma eval_condition_store:
+  forall chunk m b ofs v' m' c args v,
+  Mem.store chunk m b ofs v' = Some m' ->
+  eval_condition c args m = Some v -> eval_condition c args m' = Some v.
+Proof.
+  intros. apply eval_condition_change_mem with m; auto.
+  intros. eapply valid_pointer_store; eauto.
+Qed.
+
+Lemma eval_operation_store:
+  forall (F: Set) chunk m b ofs v' m' (ge: Genv.t F) sp op args v,
+  Mem.store chunk m b ofs v' = Some m' ->
+  eval_operation ge sp op args m = Some v -> eval_operation ge sp op args m' = Some v.
+Proof.
+  intros. apply eval_operation_change_mem with m; auto.
+  intros. eapply valid_pointer_store; eauto.
+Qed.
+
+(** Recognition of move operations. *)
+
+Definition is_move_operation
+    (A: Set) (op: operation) (args: list A) : option A :=
+  match op, args with
+  | Omove, arg :: nil => Some arg
+  | _, _ => None
+  end.
+
+Lemma is_move_operation_correct:
+  forall (A: Set) (op: operation) (args: list A) (a: A),
+  is_move_operation op args = Some a ->
+  op = Omove /\ args = a :: nil.
+Proof.
+  intros until a. unfold is_move_operation; destruct op;
+  try (intros; discriminate).
+  destruct args. intros; discriminate.
+  destruct args. intros. intuition congruence. 
+  intros; discriminate.
+Qed.
+
+(** Static typing of conditions, operators and addressing modes. *)
+
+Definition type_of_condition (c: condition) : list typ :=
+  match c with
+  | Ccomp _ => Tint :: Tint :: nil
+  | Ccompu _ => Tint :: Tint :: nil
+  | Ccompimm _ _ => Tint :: nil
+  | Ccompuimm _ _ => Tint :: nil
+  | Ccompf _ => Tfloat :: Tfloat :: nil
+  | Cnotcompf _ => Tfloat :: Tfloat :: nil
+  | Cmaskzero _ => Tint :: nil
+  | Cmasknotzero _ => Tint :: nil
+  end.
+
+Definition type_of_operation (op: operation) : list typ * typ :=
+  match op with
+  | Omove => (nil, Tint)   (* treated specially *)
+  | Ointconst _ => (nil, Tint)
+  | Ofloatconst _ => (nil, Tfloat)
+  | Oaddrsymbol _ _ => (nil, Tint)
+  | Oaddrstack _ => (nil, Tint)
+  | Ocast8signed => (Tint :: nil, Tint)
+  | Ocast8unsigned => (Tint :: nil, Tint)
+  | Ocast16signed => (Tint :: nil, Tint)
+  | Ocast16unsigned => (Tint :: nil, Tint)
+  | Oadd => (Tint :: Tint :: nil, Tint)
+  | Oaddimm _ => (Tint :: nil, Tint)
+  | Osub => (Tint :: Tint :: nil, Tint)
+  | Osubimm _ => (Tint :: nil, Tint)
+  | Omul => (Tint :: Tint :: nil, Tint)
+  | Omulimm _ => (Tint :: nil, Tint)
+  | Odiv => (Tint :: Tint :: nil, Tint)
+  | Odivu => (Tint :: Tint :: nil, Tint)
+  | Oand => (Tint :: Tint :: nil, Tint)
+  | Oandimm _ => (Tint :: nil, Tint)
+  | Oor => (Tint :: Tint :: nil, Tint)
+  | Oorimm _ => (Tint :: nil, Tint)
+  | Oxor => (Tint :: Tint :: nil, Tint)
+  | Oxorimm _ => (Tint :: nil, Tint)
+  | Onand => (Tint :: Tint :: nil, Tint)
+  | Onor => (Tint :: Tint :: nil, Tint)
+  | Onxor => (Tint :: Tint :: nil, Tint)
+  | Oshl => (Tint :: Tint :: nil, Tint)
+  | Oshr => (Tint :: Tint :: nil, Tint)
+  | Oshrimm _ => (Tint :: nil, Tint)
+  | Oshrximm _ => (Tint :: nil, Tint)
+  | Oshru => (Tint :: Tint :: nil, Tint)
+  | Orolm _ _ => (Tint :: nil, Tint)
+  | Onegf => (Tfloat :: nil, Tfloat)
+  | Oabsf => (Tfloat :: nil, Tfloat)
+  | Oaddf => (Tfloat :: Tfloat :: nil, Tfloat)
+  | Osubf => (Tfloat :: Tfloat :: nil, Tfloat)
+  | Omulf => (Tfloat :: Tfloat :: nil, Tfloat)
+  | Odivf => (Tfloat :: Tfloat :: nil, Tfloat)
+  | Omuladdf => (Tfloat :: Tfloat :: Tfloat :: nil, Tfloat)
+  | Omulsubf => (Tfloat :: Tfloat :: Tfloat :: nil, Tfloat)
+  | Osingleoffloat => (Tfloat :: nil, Tfloat)
+  | Ointoffloat => (Tfloat :: nil, Tint)
+  | Ointuoffloat => (Tfloat :: nil, Tint)
+  | Ofloatofint => (Tint :: nil, Tfloat)
+  | Ofloatofintu => (Tint :: nil, Tfloat)
+  | Ocmp c => (type_of_condition c, Tint)
+  end.
+
+Definition type_of_addressing (addr: addressing) : list typ :=
+  match addr with
+  | Aindexed _ => Tint :: nil
+  | Aindexed2 => Tint :: Tint :: nil
+  | Aglobal _ _ => nil
+  | Abased _ _ => Tint :: nil
+  | Ainstack _ => nil
+  end.
+
+Definition type_of_chunk (c: memory_chunk) : typ :=
+  match c with
+  | Mint8signed => Tint
+  | Mint8unsigned => Tint
+  | Mint16signed => Tint
+  | Mint16unsigned => Tint
+  | Mint32 => Tint
+  | Mfloat32 => Tfloat
+  | Mfloat64 => Tfloat
+  end.
+
+(** Weak type soundness results for [eval_operation]:
+  the result values, when defined, are always of the type predicted
+  by [type_of_operation]. *)
+
+Section SOUNDNESS.
+
+Variable A: Set.
+Variable genv: Genv.t A.
+
+Lemma type_of_operation_sound:
+  forall op vl sp v m,
+  op <> Omove ->
+  eval_operation genv sp op vl m = Some v ->
+  Val.has_type v (snd (type_of_operation op)).
+Proof.
+  intros.
+  destruct op; simpl in H0; FuncInv; try subst v; try exact I.
+  congruence.
+  destruct (Genv.find_symbol genv i); simplify_eq H0; intro; subst v; exact I.
+  simpl. unfold offset_sp in H0. destruct sp; try discriminate.
+  inversion H0. exact I.
+  destruct v0; exact I. 
+  destruct v0; exact I. 
+  destruct v0; exact I. 
+  destruct v0; exact I. 
+  destruct (eq_block b b0). injection H0; intro; subst v; exact I.
+  discriminate.
+  destruct (Int.eq i0 Int.zero). discriminate. 
+  injection H0; intro; subst v; exact I.
+  destruct (Int.eq i0 Int.zero). discriminate. 
+  injection H0; intro; subst v; exact I.
+  destruct (Int.ltu i0 (Int.repr 32)).
+  injection H0; intro; subst v; exact I. discriminate.
+  destruct (Int.ltu i0 (Int.repr 32)).
+  injection H0; intro; subst v; exact I. discriminate.
+  destruct (Int.ltu i (Int.repr 32)).
+  injection H0; intro; subst v; exact I. discriminate.
+  destruct (Int.ltu i (Int.repr 32)).
+  injection H0; intro; subst v; exact I. discriminate.
+  destruct (Int.ltu i0 (Int.repr 32)).
+  injection H0; intro; subst v; exact I. discriminate.
+  destruct v0; exact I.
+  destruct (eval_condition c vl). 
+  destruct b; injection H0; intro; subst v; exact I.
+  discriminate.
+Qed.
+
+Lemma type_of_chunk_correct:
+  forall chunk m addr v,
+  Mem.loadv chunk m addr = Some v ->
+  Val.has_type v (type_of_chunk chunk).
+Proof.
+  intro chunk.
+  assert (forall v, Val.has_type (Val.load_result chunk v) (type_of_chunk chunk)).
+  destruct v; destruct chunk; exact I.
+  intros until v. unfold Mem.loadv. 
+  destruct addr; intros; try discriminate.
+  generalize (Mem.load_inv _ _ _ _ _ H0).
+  intros [X Y].  subst v.  apply H.
+Qed.
+
+End SOUNDNESS.
+
+(** Alternate definition of [eval_condition], [eval_op], [eval_addressing]
+  as total functions that return [Vundef] when not applicable
+  (instead of [None]).  Used in the proof of [PPCgen]. *)
+
+Section EVAL_OP_TOTAL.
+
+Variable F: Set.
+Variable genv: Genv.t F.
+
+Definition find_symbol_offset (id: ident) (ofs: int) : val :=
+  match Genv.find_symbol genv id with
+  | Some b => Vptr b ofs
+  | None => Vundef
+  end.
+
+Definition eval_condition_total (cond: condition) (vl: list val) : val :=
+  match cond, vl with
+  | Ccomp c, v1::v2::nil => Val.cmp c v1 v2
+  | Ccompu c, v1::v2::nil => Val.cmpu c v1 v2
+  | Ccompimm c n, v1::nil => Val.cmp c v1 (Vint n)
+  | Ccompuimm c n, v1::nil => Val.cmpu c v1 (Vint n)
+  | Ccompf c, v1::v2::nil => Val.cmpf c v1 v2
+  | Cnotcompf c, v1::v2::nil => Val.notbool(Val.cmpf c v1 v2)
+  | Cmaskzero n, v1::nil => Val.notbool (Val.and v1 (Vint n))
+  | Cmasknotzero n, v1::nil => Val.notbool(Val.notbool (Val.and v1 (Vint n)))
+  | _, _ => Vundef
+  end.
+
+Definition eval_operation_total (sp: val) (op: operation) (vl: list val) : val :=
+  match op, vl with
+  | Omove, v1::nil => v1
+  | Ointconst n, nil => Vint n
+  | Ofloatconst n, nil => Vfloat n
+  | Oaddrsymbol s ofs, nil => find_symbol_offset s ofs
+  | Oaddrstack ofs, nil => Val.add sp (Vint ofs)
+  | Ocast8signed, v1::nil => Val.sign_ext 8 v1
+  | Ocast8unsigned, v1::nil => Val.zero_ext 8 v1
+  | Ocast16signed, v1::nil => Val.sign_ext 16 v1
+  | Ocast16unsigned, v1::nil => Val.zero_ext 16 v1
+  | Oadd, v1::v2::nil => Val.add v1 v2
+  | Oaddimm n, v1::nil => Val.add v1 (Vint n)
+  | Osub, v1::v2::nil => Val.sub v1 v2
+  | Osubimm n, v1::nil => Val.sub (Vint n) v1
+  | Omul, v1::v2::nil => Val.mul v1 v2
+  | Omulimm n, v1::nil => Val.mul v1 (Vint n)
+  | Odiv, v1::v2::nil => Val.divs v1 v2
+  | Odivu, v1::v2::nil => Val.divu v1 v2
+  | Oand, v1::v2::nil => Val.and v1 v2
+  | Oandimm n, v1::nil => Val.and v1 (Vint n)
+  | Oor, v1::v2::nil => Val.or v1 v2
+  | Oorimm n, v1::nil => Val.or v1 (Vint n)
+  | Oxor, v1::v2::nil => Val.xor v1 v2
+  | Oxorimm n, v1::nil => Val.xor v1 (Vint n)
+  | Onand, v1::v2::nil => Val.notint(Val.and v1 v2)
+  | Onor, v1::v2::nil => Val.notint(Val.or v1 v2)
+  | Onxor, v1::v2::nil => Val.notint(Val.xor v1 v2)
+  | Oshl, v1::v2::nil => Val.shl v1 v2
+  | Oshr, v1::v2::nil => Val.shr v1 v2
+  | Oshrimm n, v1::nil => Val.shr v1 (Vint n)
+  | Oshrximm n, v1::nil => Val.shrx v1 (Vint n)
+  | Oshru, v1::v2::nil => Val.shru v1 v2
+  | Orolm amount mask, v1::nil => Val.rolm v1 amount mask
+  | Onegf, v1::nil => Val.negf v1
+  | Oabsf, v1::nil => Val.absf v1
+  | Oaddf, v1::v2::nil => Val.addf v1 v2
+  | Osubf, v1::v2::nil => Val.subf v1 v2
+  | Omulf, v1::v2::nil => Val.mulf v1 v2
+  | Odivf, v1::v2::nil => Val.divf v1 v2
+  | Omuladdf, v1::v2::v3::nil => Val.addf (Val.mulf v1 v2) v3
+  | Omulsubf, v1::v2::v3::nil => Val.subf (Val.mulf v1 v2) v3
+  | Osingleoffloat, v1::nil => Val.singleoffloat v1
+  | Ointoffloat, v1::nil => Val.intoffloat v1
+  | Ointuoffloat, v1::nil => Val.intuoffloat v1
+  | Ofloatofint, v1::nil => Val.floatofint v1
+  | Ofloatofintu, v1::nil => Val.floatofintu v1
+  | Ocmp c, _ => eval_condition_total c vl
+  | _, _ => Vundef
+  end.
+
+Definition eval_addressing_total
+    (sp: val) (addr: addressing) (vl: list val) : val :=
+  match addr, vl with
+  | Aindexed n, v1::nil => Val.add v1 (Vint n)
+  | Aindexed2, v1::v2::nil => Val.add v1 v2
+  | Aglobal s ofs, nil => find_symbol_offset s ofs
+  | Abased s ofs, v1::nil => Val.add (find_symbol_offset s ofs) v1
+  | Ainstack ofs, nil => Val.add sp (Vint ofs)
+  | _, _ => Vundef
+  end.
+
+Lemma eval_compare_mismatch_weaken:
+  forall c b,
+  eval_compare_mismatch c = Some b ->
+  Val.cmp_mismatch c = Val.of_bool b.
+Proof.
+  unfold eval_compare_mismatch. intros. destruct c; inv H; auto.
+Qed.
+
+Lemma eval_compare_null_weaken:
+  forall n c b,
+  (if Int.eq n Int.zero then eval_compare_mismatch c else None) = Some b ->
+  (if Int.eq n Int.zero then Val.cmp_mismatch c else Vundef) = Val.of_bool b.
+Proof.
+  intros. destruct (Int.eq n Int.zero). apply eval_compare_mismatch_weaken. auto.
+  discriminate.
+Qed.
+
+Lemma eval_condition_weaken:
+  forall c vl m b,
+  eval_condition c vl m = Some b ->
+  eval_condition_total c vl = Val.of_bool b.
+Proof.
+  intros. 
+  unfold eval_condition in H; destruct c; FuncInv;
+  try subst b; try reflexivity; simpl;
+  try (apply eval_compare_null_weaken; auto).
+  destruct (valid_pointer m b0 (Int.signed i) &&
+            valid_pointer m b1 (Int.signed i0)).
+  unfold eq_block in H. destruct (zeq b0 b1).
+  congruence.
+  apply eval_compare_mismatch_weaken; auto.
+  discriminate.
+  symmetry. apply Val.notbool_negb_1. 
+  symmetry. apply Val.notbool_negb_1. 
+Qed.
+
+Lemma eval_operation_weaken:
+  forall sp op vl m v,
+  eval_operation genv sp op vl m = Some v ->
+  eval_operation_total sp op vl = v.
+Proof.
+  intros.
+  unfold eval_operation in H; destruct op; FuncInv;
+  try subst v; try reflexivity; simpl.
+  unfold find_symbol_offset. 
+  destruct (Genv.find_symbol genv i); try discriminate.
+  congruence.
+  unfold offset_sp in H. 
+  destruct sp; try discriminate. simpl. congruence.
+  unfold eq_block in H. destruct (zeq b b0); congruence.
+  destruct (Int.eq i0 Int.zero); congruence.
+  destruct (Int.eq i0 Int.zero); congruence.
+  destruct (Int.ltu i0 (Int.repr 32)); congruence.
+  destruct (Int.ltu i0 (Int.repr 32)); congruence.
+  destruct (Int.ltu i (Int.repr 32)); congruence.
+  destruct (Int.ltu i (Int.repr 32)); congruence.
+  destruct (Int.ltu i0 (Int.repr 32)); congruence.
+  caseEq (eval_condition c vl m); intros; rewrite H0 in H.
+  replace v with (Val.of_bool b).
+  eapply eval_condition_weaken; eauto.
+  destruct b; simpl; congruence.
+  discriminate.
+Qed.
+
+Lemma eval_addressing_weaken:
+  forall sp addr vl v,
+  eval_addressing genv sp addr vl = Some v ->
+  eval_addressing_total sp addr vl = v.
+Proof.
+  intros.
+  unfold eval_addressing in H; destruct addr; FuncInv;
+  try subst v; simpl; try reflexivity.
+  unfold find_symbol_offset. 
+  destruct (Genv.find_symbol genv i); congruence.
+  unfold find_symbol_offset.
+  destruct (Genv.find_symbol genv i); try congruence.
+  inversion H. reflexivity.
+  unfold offset_sp in H. destruct sp; simpl; congruence.
+Qed.
+
+Lemma eval_condition_total_is_bool:
+  forall cond vl, Val.is_bool (eval_condition_total cond vl).
+Proof.
+  intros; destruct cond;
+  destruct vl; try apply Val.undef_is_bool;
+  destruct vl; try apply Val.undef_is_bool;
+  try (destruct vl; try apply Val.undef_is_bool); simpl.
+  apply Val.cmp_is_bool.
+  apply Val.cmpu_is_bool.
+  apply Val.cmp_is_bool.
+  apply Val.cmpu_is_bool.
+  apply Val.cmpf_is_bool.
+  apply Val.notbool_is_bool.
+  apply Val.notbool_is_bool.
+  apply Val.notbool_is_bool.
+Qed.
+
+End EVAL_OP_TOTAL.
+
+(** Compatibility of the evaluation functions with the
+    ``is less defined'' relation over values and memory states. *)
+
+Section EVAL_LESSDEF.
+
+Variable F: Set.
+Variable genv: Genv.t F.
+Variables m1 m2: mem.
+Hypothesis MEM: Mem.lessdef m1 m2.
+
+Ltac InvLessdef :=
+  match goal with
+  | [ H: Val.lessdef (Vint _) _ |- _ ] =>
+      inv H; InvLessdef
+  | [ H: Val.lessdef (Vfloat _) _ |- _ ] =>
+      inv H; InvLessdef
+  | [ H: Val.lessdef (Vptr _ _) _ |- _ ] =>
+      inv H; InvLessdef
+  | [ H: Val.lessdef_list nil _ |- _ ] =>
+      inv H; InvLessdef
+  | [ H: Val.lessdef_list (_ :: _) _ |- _ ] =>
+      inv H; InvLessdef
+  | _ => idtac
+  end.
+
+Lemma eval_condition_lessdef:
+  forall cond vl1 vl2 b,
+  Val.lessdef_list vl1 vl2 ->
+  eval_condition cond vl1 m1 = Some b ->
+  eval_condition cond vl2 m2 = Some b.
+Proof.
+  intros. destruct cond; simpl in *; FuncInv; InvLessdef; auto.
+  generalize H0.
+  caseEq (valid_pointer m1 b0 (Int.signed i)); intro; simpl; try congruence.
+  caseEq (valid_pointer m1 b1 (Int.signed i0)); intro; simpl; try congruence.
+  rewrite (Mem.valid_pointer_lessdef _ _ _ _ MEM H1).
+  rewrite (Mem.valid_pointer_lessdef _ _ _ _ MEM H). simpl.
+  auto.
+Qed.
+
+Ltac TrivialExists :=
+  match goal with
+  | [ |- exists v2, Some ?v1 = Some v2 /\ Val.lessdef ?v1 v2 ] =>
+      exists v1; split; [auto | constructor]
+  | _ => idtac
+  end.
+
+Lemma eval_operation_lessdef:
+  forall sp op vl1 vl2 v1,
+  Val.lessdef_list vl1 vl2 ->
+  eval_operation genv sp op vl1 m1 = Some v1 ->
+  exists v2, eval_operation genv sp op vl2 m2 = Some v2 /\ Val.lessdef v1 v2.
+Proof.
+  intros. destruct op; simpl in *; FuncInv; InvLessdef; TrivialExists.
+  exists v2; auto.
+  destruct (Genv.find_symbol genv i); inv H0. TrivialExists.
+  exists v1; auto.
+  exists (Val.sign_ext 8 v2); split. auto. apply Val.sign_ext_lessdef; auto.
+  exists (Val.zero_ext 8 v2); split. auto. apply Val.zero_ext_lessdef; auto.
+  exists (Val.sign_ext 16 v2); split. auto. apply Val.sign_ext_lessdef; auto.
+  exists (Val.zero_ext 16 v2); split. auto. apply Val.zero_ext_lessdef; auto.
+  destruct (eq_block b b0); inv H0. TrivialExists.
+  destruct (Int.eq i0 Int.zero); inv H0; TrivialExists.
+  destruct (Int.eq i0 Int.zero); inv H0; TrivialExists.
+  destruct (Int.ltu i0 (Int.repr 32)); inv H0; TrivialExists.
+  destruct (Int.ltu i0 (Int.repr 32)); inv H0; TrivialExists.
+  destruct (Int.ltu i (Int.repr 32)); inv H0; TrivialExists.
+  destruct (Int.ltu i (Int.repr 32)); inv H0; TrivialExists.
+  destruct (Int.ltu i0 (Int.repr 32)); inv H0; TrivialExists.
+  exists (Val.singleoffloat v2); split. auto. apply Val.singleoffloat_lessdef; auto.
+  caseEq (eval_condition c vl1 m1); intros. rewrite H1 in H0. 
+  rewrite (eval_condition_lessdef c H H1).
+  destruct b; inv H0; TrivialExists.
+  rewrite H1 in H0. discriminate.
+Qed.
+
+Lemma eval_addressing_lessdef:
+  forall sp addr vl1 vl2 v1,
+  Val.lessdef_list vl1 vl2 ->
+  eval_addressing genv sp addr vl1 = Some v1 ->
+  exists v2, eval_addressing genv sp addr vl2 = Some v2 /\ Val.lessdef v1 v2.
+Proof.
+  intros. destruct addr; simpl in *; FuncInv; InvLessdef; TrivialExists.
+  destruct (Genv.find_symbol genv i); inv H0. TrivialExists.
+  destruct (Genv.find_symbol genv i); inv H0. TrivialExists.
+  exists v1; auto.
+Qed.
+
+End EVAL_LESSDEF.
+
+(** Transformation of addressing modes with two operands or more
+  into an equivalent arithmetic operation.  This is used in the [Reload]
+  pass when a store instruction cannot be reloaded directly because
+  it runs out of temporary registers. *)
+
+(** For the PowerPC, there is only one binary addressing mode: [Aindexed2].
+  The corresponding operation is [Oadd]. *)
+
+Definition op_for_binary_addressing (addr: addressing) : operation := Oadd.
+
+Lemma eval_op_for_binary_addressing:
+  forall (F: Set) (ge: Genv.t F) sp addr args m v,
+  (length args >= 2)%nat ->
+  eval_addressing ge sp addr args = Some v ->
+  eval_operation ge sp (op_for_binary_addressing addr) args m = Some v.
+Proof.
+  intros.
+  unfold eval_addressing in H0; destruct addr; FuncInv; simpl in H; try omegaContradiction;
+  simpl; congruence.
+Qed.
+
+Lemma type_op_for_binary_addressing:
+  forall addr,
+  (length (type_of_addressing addr) >= 2)%nat ->
+  type_of_operation (op_for_binary_addressing addr) = (type_of_addressing addr, Tint).
+Proof.
+  intros. destruct addr; simpl in H; reflexivity || omegaContradiction.
+Qed.
diff --git a/powerpc/PrintAsm.ml b/powerpc/PrintAsm.ml
new file mode 100644
index 00000000..0e45c848
--- /dev/null
+++ b/powerpc/PrintAsm.ml
@@ -0,0 +1,532 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              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.     *)
+(*                                                                     *)
+(* *********************************************************************)
+
+(* Printing PPC assembly code in asm syntax *)
+
+open Printf
+open Datatypes
+open CList
+open Camlcoq
+open AST
+open Asm
+
+(* On-the-fly label renaming *)
+
+let next_label = ref 100
+
+let new_label() =
+  let lbl = !next_label in incr next_label; lbl
+
+let current_function_labels = (Hashtbl.create 39 : (label, int) Hashtbl.t)
+
+let label_for_label lbl =
+  try
+    Hashtbl.find current_function_labels lbl
+  with Not_found ->
+    let lbl' = new_label() in
+    Hashtbl.add current_function_labels lbl lbl';
+    lbl'
+
+(* Record identifiers of external functions *)
+
+module IdentSet = Set.Make(struct type t = ident let compare = compare end)
+
+let extfuns = ref IdentSet.empty
+
+let record_extfun (Coq_pair(name, defn)) =
+  match defn with
+  | Internal _ -> ()
+  | External _ -> extfuns := IdentSet.add name !extfuns
+
+(* Basic printing functions *)
+
+let print_symb oc symb =
+  if IdentSet.mem symb !extfuns
+  then fprintf oc "L%s$stub" (extern_atom symb)
+  else fprintf oc "_%s" (extern_atom symb)
+
+let print_label oc lbl =
+  fprintf oc "L%d" (label_for_label lbl)
+
+let print_symb_ofs oc (symb, ofs) =
+  print_symb oc symb;
+  if ofs <> 0l then fprintf oc " + %ld" ofs
+
+let print_constant oc = function
+  | Cint n ->
+      fprintf oc "%ld" (camlint_of_coqint n)
+  | Csymbol_low(s, n) ->
+      fprintf oc "lo16(%a)" print_symb_ofs (s, camlint_of_coqint n)
+  | Csymbol_high(s, n) ->
+      fprintf oc "ha16(%a)" print_symb_ofs (s, camlint_of_coqint n)
+
+let num_crbit = function
+  | CRbit_0 -> 0
+  | CRbit_1 -> 1
+  | CRbit_2 -> 2
+  | CRbit_3 -> 3
+
+let print_crbit oc bit =
+  fprintf oc "%d" (num_crbit bit)
+
+let print_coqint oc n =
+  fprintf oc "%ld" (camlint_of_coqint n)
+
+let int_reg_name = 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"
+  | GPR12 -> "r12" | GPR13 -> "r13" | GPR14 -> "r14" | GPR15 -> "r15"
+  | GPR16 -> "r16" | GPR17 -> "r17" | GPR18 -> "r18" | GPR19 -> "r19"
+  | GPR20 -> "r20" | GPR21 -> "r21" | GPR22 -> "r22" | GPR23 -> "r23"
+  | GPR24 -> "r24" | GPR25 -> "r25" | GPR26 -> "r26" | GPR27 -> "r27"
+  | GPR28 -> "r28" | GPR29 -> "r29" | GPR30 -> "r30" | GPR31 -> "r31"
+
+let float_reg_name = function
+  | FPR0 -> "f0"  | FPR1 -> "f1"  | FPR2 -> "f2"  | FPR3 -> "f3"
+  | FPR4 -> "f4"  | FPR5 -> "f5"  | FPR6 -> "f6"  | FPR7 -> "f7"
+  | FPR8 -> "f8"  | FPR9 -> "f9"  | FPR10 -> "f10" | FPR11 -> "f11"
+  | FPR12 -> "f12" | FPR13 -> "f13" | FPR14 -> "f14" | FPR15 -> "f15"
+  | FPR16 -> "f16" | FPR17 -> "f17" | FPR18 -> "f18" | FPR19 -> "f19"
+  | FPR20 -> "f20" | FPR21 -> "f21" | FPR22 -> "f22" | FPR23 -> "f23"
+  | FPR24 -> "f24" | FPR25 -> "f25" | FPR26 -> "f26" | FPR27 -> "f27"
+  | FPR28 -> "f28" | FPR29 -> "f29" | FPR30 -> "f30" | FPR31 -> "f31"
+
+let ireg oc r = output_string oc (int_reg_name r)
+let ireg_or_zero oc r = if r = GPR0 then output_string oc "0" else ireg oc r
+let freg oc r = output_string oc (float_reg_name r)
+
+(* Printing of instructions *)
+
+module Labelset = Set.Make(struct type t = label let compare = compare end)
+
+let print_instruction oc labels = function
+  | Padd(r1, r2, r3) ->
+      fprintf oc "	add	%a, %a, %a\n" ireg r1 ireg r2 ireg r3
+  | Paddi(r1, r2, c) ->
+      fprintf oc "	addi	%a, %a, %a\n" ireg r1 ireg_or_zero r2 print_constant c
+  | Paddis(r1, r2, c) ->
+      fprintf oc "	addis	%a, %a, %a\n" ireg r1 ireg_or_zero r2 print_constant c
+  | Paddze(r1, r2) ->
+      fprintf oc "	addze	%a, %a\n" ireg r1 ireg r2
+  | Pallocblock ->
+      fprintf oc "	bl	_compcert_alloc\n"
+  | Pallocframe(lo, hi, ofs) ->
+      let lo = camlint_of_coqint lo
+      and hi = camlint_of_coqint hi
+      and ofs = camlint_of_coqint ofs in
+      let sz = Int32.sub hi lo in
+      (* Keep stack 16-aligned *)
+      let sz16 = Int32.logand (Int32.add sz 15l) 0xFFFF_FFF0l in
+      assert (ofs = 0l);
+      fprintf oc "	stwu	r1, %ld(r1)\n" (Int32.neg sz16)
+  | Pand_(r1, r2, r3) ->
+      fprintf oc "	and.	%a, %a, %a\n" ireg r1 ireg r2 ireg r3
+  | Pandc(r1, r2, r3) ->
+      fprintf oc "	andc	%a, %a, %a\n" ireg r1 ireg r2 ireg r3
+  | Pandi_(r1, r2, c) ->
+      fprintf oc "	andi.	%a, %a, %a\n" ireg r1 ireg r2 print_constant c
+  | Pandis_(r1, r2, c) ->
+      fprintf oc "	andis.	%a, %a, %a\n" ireg r1 ireg r2 print_constant c
+  | Pb lbl ->
+      fprintf oc "	b	%a\n" print_label lbl
+  | Pbctr ->
+      fprintf oc "	bctr\n"
+  | Pbctrl ->
+      fprintf oc "	bctrl\n"
+  | Pbf(bit, lbl) ->
+      fprintf oc "	bf	%a, %a\n" print_crbit bit print_label lbl
+  | Pbl s ->
+      fprintf oc "	bl	%a\n" print_symb s
+  | Pbs s ->
+      fprintf oc "	b	%a\n" print_symb s
+  | Pblr ->
+      fprintf oc "	blr\n"
+  | Pbt(bit, lbl) ->
+      fprintf oc "	bt	%a, %a\n" print_crbit bit print_label lbl
+  | Pcmplw(r1, r2) ->
+      fprintf oc "	cmplw	cr0, %a, %a\n" ireg r1 ireg r2
+  | Pcmplwi(r1, c) ->
+      fprintf oc "	cmplwi	cr0, %a, %a\n" ireg r1 print_constant c
+  | Pcmpw(r1, r2) ->
+      fprintf oc "	cmpw	cr0, %a, %a\n" ireg r1 ireg r2
+  | Pcmpwi(r1, c) ->
+      fprintf oc "	cmpwi	cr0, %a, %a\n" ireg r1 print_constant c
+  | Pcror(c1, c2, c3) ->
+      fprintf oc "	cror	%a, %a, %a\n" print_crbit c1 print_crbit c2 print_crbit c3
+  | Pdivw(r1, r2, r3) ->
+      fprintf oc "	divw	%a, %a, %a\n" ireg r1 ireg r2 ireg r3
+  | Pdivwu(r1, r2, r3) ->
+      fprintf oc "	divwu	%a, %a, %a\n" ireg r1 ireg r2 ireg r3
+  | Peqv(r1, r2, r3) ->
+      fprintf oc "	eqv	%a, %a, %a\n" ireg r1 ireg r2 ireg r3
+  | Pextsb(r1, r2) ->
+      fprintf oc "	extsb	%a, %a\n" ireg r1 ireg r2
+  | Pextsh(r1, r2) ->
+      fprintf oc "	extsh	%a, %a\n" ireg r1 ireg r2
+  | Pfreeframe ofs ->
+      fprintf oc "	lwz	r1, %ld(r1)\n" (camlint_of_coqint ofs)
+  | Pfabs(r1, r2) ->
+      fprintf oc "	fabs	%a, %a\n" freg r1 freg r2
+  | Pfadd(r1, r2, r3) ->
+      fprintf oc "	fadd	%a, %a, %a\n" freg r1 freg r2 freg r3
+  | Pfcmpu(r1, r2) ->
+      fprintf oc "	fcmpu	cr0, %a, %a\n" freg r1 freg r2
+  | Pfcti(r1, r2) ->
+      fprintf oc "	fctiwz	f13, %a\n" freg r2;
+      fprintf oc "	stfd	f13, -8(r1)\n";
+      fprintf oc "	lwz	%a, -4(r1)\n" ireg r1
+  | Pfctiu(r1, r2) ->
+      let lbl1 = new_label() in
+      let lbl2 = new_label() in
+      let lbl3 = new_label() in
+      fprintf oc "	addis	r12, 0, ha16(L%d)\n" lbl1;
+      fprintf oc "	lfd	f13, lo16(L%d)(r12)\n" lbl1;
+      fprintf oc "	fcmpu	cr7, %a, f13\n" freg r2;
+      fprintf oc "	cror	30, 29, 30\n";
+      fprintf oc "	beq	cr7, L%d\n" lbl2;
+      fprintf oc "	fctiwz	f13, %a\n" freg r2;
+      fprintf oc "	stfdu	f13, -8(r1)\n";
+      fprintf oc "	lwz	%a, 4(r1)\n" ireg r1;
+      fprintf oc "	b	L%d\n" lbl3;
+      fprintf oc "L%d:	fsub	f13, %a, f13\n" lbl2 freg r2;
+      fprintf oc "	fctiwz	f13, f13\n";
+      fprintf oc "	stfdu	f13, -8(r1)\n";
+      fprintf oc "	lwz	%a, 4(r1)\n" ireg r1;
+      fprintf oc "	addis	%a, %a, 0x8000\n" ireg r1 ireg r1;
+      fprintf oc "L%d:	addi	r1, r1, 8\n" lbl3;
+      fprintf oc "	.const_data\n";
+      fprintf oc "L%d:	.long	0x41e00000, 0x00000000\n" lbl1;
+      fprintf oc "	.text\n"
+  | Pfdiv(r1, r2, r3) ->
+      fprintf oc "	fdiv	%a, %a, %a\n" freg r1 freg r2 freg r3
+  | Pfmadd(r1, r2, r3, r4) ->
+      fprintf oc "	fmadd	%a, %a, %a, %a\n" freg r1 freg r2 freg r3 freg r4
+  | Pfmr(r1, r2) ->
+      fprintf oc "	fmr	%a, %a\n" freg r1 freg r2
+  | Pfmsub(r1, r2, r3, r4) ->
+      fprintf oc "	fmsub	%a, %a, %a, %a\n" freg r1 freg r2 freg r3 freg r4
+  | Pfmul(r1, r2, r3) ->
+      fprintf oc "	fmul	%a, %a, %a\n" freg r1 freg r2 freg r3
+  | Pfneg(r1, r2) ->
+      fprintf oc "	fneg	%a, %a\n" freg r1 freg r2
+  | Pfrsp(r1, r2) ->
+      fprintf oc "	frsp	%a, %a\n" freg r1 freg r2
+  | Pfsub(r1, r2, r3) ->
+      fprintf oc "	fsub	%a, %a, %a\n" freg r1 freg r2 freg r3
+  | Pictf(r1, r2) ->
+      let lbl = new_label() in
+      fprintf oc "	addis	r12, 0, 0x4330\n";
+      fprintf oc "	stw	r12, -8(r1)\n";
+      fprintf oc "	addis	r12, %a, 0x8000\n" ireg r2;
+      fprintf oc "	stw	r12, -4(r1)\n";
+      fprintf oc "	addis	r12, 0, ha16(L%d)\n" lbl;
+      fprintf oc "	lfd	f13, lo16(L%d)(r12)\n" lbl;
+      fprintf oc "	lfd	%a, -8(r1)\n" freg r1;
+      fprintf oc "	fsub	%a, %a, f13\n" freg r1 freg r1;
+      fprintf oc "	.const_data\n";
+      fprintf oc "L%d:	.long	0x43300000, 0x80000000\n" lbl;
+      fprintf oc "	.text\n"
+  | Piuctf(r1, r2) ->
+      let lbl = new_label() in
+      fprintf oc "	addis	r12, 0, 0x4330\n";
+      fprintf oc "	stw	r12, -8(r1)\n";
+      fprintf oc "	stw	%a, -4(r1)\n" ireg r2;
+      fprintf oc "	addis	r12, 0, ha16(L%d)\n" lbl;
+      fprintf oc "	lfd	f13, lo16(L%d)(r12)\n" lbl;
+      fprintf oc "	lfd	%a, -8(r1)\n" freg r1;
+      fprintf oc "	fsub	%a, %a, f13\n" freg r1 freg r1;
+      fprintf oc "	.const_data\n";
+      fprintf oc "L%d:	.long	0x43300000, 0x00000000\n" lbl;
+      fprintf oc "	.text\n"
+  | Plbz(r1, c, r2) ->
+      fprintf oc "	lbz	%a, %a(%a)\n" ireg r1 print_constant c ireg r2
+  | Plbzx(r1, r2, r3) ->
+      fprintf oc "	lbzx	%a, %a, %a\n" ireg r1 ireg r2 ireg r3
+  | Plfd(r1, c, r2) ->
+      fprintf oc "	lfd	%a, %a(%a)\n" freg r1 print_constant c ireg r2
+  | Plfdx(r1, r2, r3) ->
+      fprintf oc "	lfdx	%a, %a, %a\n" freg r1 ireg r2 ireg r3
+  | Plfi(r1, c) ->
+      let lbl = new_label() in
+      fprintf oc "	addis	r12, 0, ha16(L%d)\n" lbl;
+      fprintf oc "	lfd	%a, lo16(L%d)(r12)\n" freg r1 lbl;
+      fprintf oc "	.const_data\n";
+      let n = Int64.bits_of_float c in
+      let nlo = Int64.to_int32 n
+      and nhi = Int64.to_int32(Int64.shift_right_logical n 32) in
+      fprintf oc "L%d:	.long	0x%lx, 0x%lx   ; %f\n" lbl nhi nlo c;
+      fprintf oc "	.text\n"
+  | Plfs(r1, c, r2) ->
+      fprintf oc "	lfs	%a, %a(%a)\n" freg r1 print_constant c ireg r2
+  | Plfsx(r1, r2, r3) ->
+      fprintf oc "	lfsx	%a, %a, %a\n" freg r1 ireg r2 ireg r3
+  | Plha(r1, c, r2) ->
+      fprintf oc "	lha	%a, %a(%a)\n" ireg r1 print_constant c ireg r2
+  | Plhax(r1, r2, r3) ->
+      fprintf oc "	lhax	%a, %a, %a\n" ireg r1 ireg r2 ireg r3
+  | Plhz(r1, c, r2) ->
+      fprintf oc "	lhz	%a, %a(%a)\n" ireg r1 print_constant c ireg r2
+  | Plhzx(r1, r2, r3) ->
+      fprintf oc "	lhzx	%a, %a, %a\n" ireg r1 ireg r2 ireg r3
+  | Plwz(r1, c, r2) ->
+      fprintf oc "	lwz	%a, %a(%a)\n" ireg r1 print_constant c ireg r2
+  | Plwzx(r1, r2, r3) ->
+      fprintf oc "	lwzx	%a, %a, %a\n" ireg r1 ireg r2 ireg r3
+  | Pmfcrbit(r1, bit) ->
+      fprintf oc "	mfcr	r2\n";
+      fprintf oc "	rlwinm	%a, r2, %d, 1\n" ireg r1 (1 + num_crbit bit)
+  | Pmflr(r1) ->
+      fprintf oc "	mflr	%a\n" ireg r1
+  | Pmr(r1, r2) ->
+      fprintf oc "	mr	%a, %a\n" ireg r1 ireg r2
+  | Pmtctr(r1) ->
+      fprintf oc "	mtctr	%a\n" ireg r1
+  | Pmtlr(r1) ->
+      fprintf oc "	mtlr	%a\n" ireg r1
+  | Pmulli(r1, r2, c) ->
+      fprintf oc "	mulli	%a, %a, %a\n" ireg r1 ireg r2 print_constant c
+  | Pmullw(r1, r2, r3) ->
+      fprintf oc "	mullw	%a, %a, %a\n" ireg r1 ireg r2 ireg r3
+  | Pnand(r1, r2, r3) ->
+      fprintf oc "	nand	%a, %a, %a\n" ireg r1 ireg r2 ireg r3
+  | Pnor(r1, r2, r3) ->
+      fprintf oc "	nor	%a, %a, %a\n" ireg r1 ireg r2 ireg r3
+  | Por(r1, r2, r3) ->
+      fprintf oc "	or	%a, %a, %a\n" ireg r1 ireg r2 ireg r3
+  | Porc(r1, r2, r3) ->
+      fprintf oc "	orc	%a, %a, %a\n" ireg r1 ireg r2 ireg r3
+  | Pori(r1, r2, c) ->
+      fprintf oc "	ori	%a, %a, %a\n" ireg r1 ireg r2 print_constant c
+  | Poris(r1, r2, c) ->
+      fprintf oc "	oris	%a, %a, %a\n" ireg r1 ireg r2 print_constant c
+  | Prlwinm(r1, r2, c1, c2) ->
+      fprintf oc "	rlwinm	%a, %a, %ld, 0x%lx\n"
+                ireg r1 ireg r2 (camlint_of_coqint c1) (camlint_of_coqint c2)
+  | Pslw(r1, r2, r3) ->
+      fprintf oc "	slw	%a, %a, %a\n" ireg r1 ireg r2 ireg r3
+  | Psraw(r1, r2, r3) ->
+      fprintf oc "	sraw	%a, %a, %a\n" ireg r1 ireg r2 ireg r3
+  | Psrawi(r1, r2, c) ->
+      fprintf oc "	srawi	%a, %a, %ld\n" ireg r1 ireg r2 (camlint_of_coqint c)
+  | Psrw(r1, r2, r3) ->
+      fprintf oc "	srw	%a, %a, %a\n" ireg r1 ireg r2 ireg r3
+  | Pstb(r1, c, r2) ->
+      fprintf oc "	stb	%a, %a(%a)\n" ireg r1 print_constant c ireg r2
+  | Pstbx(r1, r2, r3) ->
+      fprintf oc "	stbx	%a, %a, %a\n" ireg r1 ireg r2 ireg r3
+  | Pstfd(r1, c, r2) ->
+      fprintf oc "	stfd	%a, %a(%a)\n" freg r1 print_constant c ireg r2
+  | Pstfdx(r1, r2, r3) ->
+      fprintf oc "	stfdx	%a, %a, %a\n" freg r1 ireg r2 ireg r3
+  | Pstfs(r1, c, r2) ->
+      fprintf oc "	stfs	%a, %a(%a)\n" freg r1 print_constant c ireg r2
+  | Pstfsx(r1, r2, r3) ->
+      fprintf oc "	stfsx	%a, %a, %a\n" freg r1 ireg r2 ireg r3
+  | Psth(r1, c, r2) ->
+      fprintf oc "	sth	%a, %a(%a)\n" ireg r1 print_constant c ireg r2
+  | Psthx(r1, r2, r3) ->
+      fprintf oc "	sthx	%a, %a, %a\n" ireg r1 ireg r2 ireg r3
+  | Pstw(r1, c, r2) ->
+      fprintf oc "	stw	%a, %a(%a)\n" ireg r1 print_constant c ireg r2
+  | Pstwx(r1, r2, r3) ->
+      fprintf oc "	stwx	%a, %a, %a\n" ireg r1 ireg r2 ireg r3
+  | Psubfc(r1, r2, r3) ->
+      fprintf oc "	subfc	%a, %a, %a\n" ireg r1 ireg r2 ireg r3
+  | Psubfic(r1, r2, c) ->
+      fprintf oc "	subfic	%a, %a, %a\n" ireg r1 ireg r2 print_constant c
+  | Pxor(r1, r2, r3) ->
+      fprintf oc "	xor	%a, %a, %a\n" ireg r1 ireg r2 ireg r3
+  | Pxori(r1, r2, c) ->
+      fprintf oc "	xori	%a, %a, %a\n" ireg r1 ireg r2 print_constant c
+  | Pxoris(r1, r2, c) ->
+      fprintf oc "	xoris	%a, %a, %a\n" ireg r1 ireg r2 print_constant c
+  | Plabel lbl ->
+      if Labelset.mem lbl labels then fprintf oc "%a:\n" print_label lbl
+
+let rec labels_of_code = function
+  | [] -> Labelset.empty
+  | (Pb lbl | Pbf(_, lbl) | Pbt(_, lbl)) :: c ->
+      Labelset.add lbl (labels_of_code c)
+  | _ :: c -> labels_of_code c
+
+let print_function oc name code =
+  Hashtbl.clear current_function_labels;
+  fprintf oc "	.text\n";
+  fprintf oc "	.align 2\n";
+  fprintf oc "	.globl %a\n" print_symb name;
+  fprintf oc "%a:\n" print_symb name;
+  List.iter (print_instruction oc (labels_of_code code)) code
+
+(* Generation of stub code for variadic functions, e.g. printf.
+   Calling conventions for variadic functions are:
+     - always reserve 8 stack words (offsets 24 to 52) so that the
+       variadic function can save there the integer registers parameters
+       r3 ... r10
+     - treat float arguments as pairs of integers, i.e. if we
+       must pass them in registers, use a pair of integer registers
+       for this purpose.
+   The code we generate is:
+     - allocate large enough stack frame
+     - save return address
+     - copy our arguments (registers and stack) to the stack frame,
+       starting at offset 24
+     - load relevant integer parameter registers r3...r10 from the
+       stack frame, limited by the actual number of arguments
+     - call the variadic thing
+     - deallocate stack frame and return
+*)
+
+let variadic_stub oc stub_name fun_name ty_args =
+  (* Compute total size of arguments *)
+  let arg_size =
+    CList.fold_left
+     (fun sz ty -> match ty with Tint -> sz + 4 | Tfloat -> sz + 8)
+     ty_args 0 in
+  (* Stack size is linkage area + argument size, with a minimum of 56 bytes *)
+  let frame_size = max 56 (24 + arg_size) in
+  fprintf oc "	mflr	r0\n";
+  fprintf oc "	stwu	r1, %d(r1)\n" (-frame_size);
+  fprintf oc "	stw	r0, %d(r1)\n" (frame_size + 4);
+  (* Copy our parameters to our stack frame.
+     As an optimization, don't copy parameters that are already in
+     integer registers, since these stay in place. *)
+  let rec copy gpr fpr src_ofs dst_ofs = function
+    | [] -> ()
+    | Tint :: rem ->
+        if gpr > 10 then begin
+          fprintf oc "	lwz	r0, %d(r1)\n" src_ofs;
+          fprintf oc "	stw	r0, %d(r1)\n" dst_ofs
+        end;
+        copy (gpr + 1) fpr (src_ofs + 4) (dst_ofs + 4) rem
+    | Tfloat :: rem ->
+        if fpr <= 10 then begin
+          fprintf oc "	stfd	f%d, %d(r1)\n" fpr dst_ofs
+        end else begin
+          fprintf oc "	lfd	f0, %d(r1)\n" src_ofs;
+          fprintf oc "	stfd	f0, %d(r1)\n" dst_ofs
+        end;
+        copy (gpr + 2) (fpr + 1) (src_ofs + 8) (dst_ofs + 8) rem
+  in copy 3 1 (frame_size + 24) 24 ty_args;
+  (* Load the first parameters into integer registers.
+     As an optimization, don't load parameters that are already
+     in the correct integer registers. *)
+  let rec load gpr ofs = function
+    | [] -> ()
+    | Tint :: rem ->
+        load (gpr + 1) (ofs + 4) rem
+    | Tfloat :: rem ->
+        if gpr <= 10 then
+          fprintf oc "	lwz	r%d, %d(r1)\n" gpr ofs;
+        if gpr + 1 <= 10 then
+          fprintf oc "	lwz	r%d, %d(r1)\n" (gpr + 1) (ofs + 4);
+        load (gpr + 2) (ofs + 8) rem
+  in load 3 24 ty_args;
+  (* Call the function *)
+  fprintf oc "	addis	r11, 0, ha16(L%s$ptr)\n" stub_name;
+  fprintf oc "	lwz	r11, lo16(L%s$ptr)(r11)\n" stub_name;
+  fprintf oc "	mtctr	r11\n";
+  fprintf oc "	bctrl\n";
+  (* Free our frame and return *)
+  fprintf oc "	lwz	r0, %d(r1)\n" (frame_size + 4);
+  fprintf oc "	mtlr	r0\n";
+  fprintf oc "	addi	r1, r1, %d\n" frame_size;
+  fprintf oc "	blr\n";
+  (* The function pointer *)
+  fprintf oc "	.non_lazy_symbol_pointer\n";
+  fprintf oc "L%s$ptr:\n" stub_name;
+  fprintf oc "	.indirect_symbol _%s\n" fun_name;
+  fprintf oc "	.long	0\n"
+
+(* Stubs for fixed-type functions are much simpler *)
+
+let non_variadic_stub oc name =
+  fprintf oc "	addis	r11, 0, ha16(L%s$ptr)\n" name;
+  fprintf oc "	lwz	r11, lo16(L%s$ptr)(r11)\n" name;
+  fprintf oc "	mtctr	r11\n";
+  fprintf oc "	bctr\n";
+  fprintf oc "	.non_lazy_symbol_pointer\n";
+  fprintf oc "L%s$ptr:\n" name;
+  fprintf oc "	.indirect_symbol _%s\n" name;
+  fprintf oc "	.long	0\n"
+
+let re_variadic_stub = Str.regexp "\\(.*\\)\\$[if]*$"
+
+let print_external_function oc name ef =
+  let name = extern_atom name in
+  fprintf oc "	.text\n";
+  fprintf oc "	.align 2\n";
+  fprintf oc "L%s$stub:\n" name;
+  if Str.string_match re_variadic_stub name 0
+  then variadic_stub oc name (Str.matched_group 1 name) ef.ef_sig.sig_args
+  else non_variadic_stub oc name
+
+let print_fundef oc (Coq_pair(name, defn)) =
+  match defn with
+  | Internal code -> print_function oc name code
+  | External ef -> print_external_function oc name ef
+
+let init_data_queue = ref []
+
+let print_init oc = function
+  | Init_int8 n ->
+      fprintf oc "	.byte	%ld\n" (camlint_of_coqint n)
+  | Init_int16 n ->
+      fprintf oc "	.short	%ld\n" (camlint_of_coqint n)
+  | Init_int32 n ->
+      fprintf oc "	.long	%ld\n" (camlint_of_coqint n)
+  | Init_float32 n ->
+      fprintf oc "	.long	%ld ; %g \n" (Int32.bits_of_float n) n
+  | Init_float64 n ->
+      (* .quad not working on all versions of the MacOSX assembler *)
+      let b = Int64.bits_of_float n in
+      fprintf oc "	.long	%Ld, %Ld ; %g \n"
+                 (Int64.shift_right_logical b 32)
+                 (Int64.logand b 0xFFFFFFFFL)
+                 n
+  | Init_space n ->
+      let n = camlint_of_z n in
+      if n > 0l then fprintf oc "	.space	%ld\n" n
+  | Init_pointer id ->
+      let lbl = new_label() in
+      fprintf oc "	.long	L%d\n" lbl;
+      init_data_queue := (lbl, id) :: !init_data_queue
+
+let print_init_data oc id =
+  init_data_queue := [];
+  List.iter (print_init oc) id;
+  let rec print_remainder () =
+    match !init_data_queue with
+    | [] -> ()
+    | (lbl, id) :: rem ->
+        init_data_queue := rem;
+        fprintf oc "L%d:\n" lbl;
+        List.iter (print_init oc) id;
+        print_remainder()
+  in print_remainder()
+
+let print_var oc (Coq_pair(Coq_pair(name, init_data), _)) =
+  match init_data with
+  | [] -> ()
+  | _  ->
+      fprintf oc "	.data\n";
+      fprintf oc "	.align	3\n";
+      fprintf oc "	.globl	%a\n" print_symb name;
+      fprintf oc "%a:\n" print_symb name;
+      print_init_data oc init_data
+
+let print_program oc p =
+  extfuns := IdentSet.empty;
+  List.iter record_extfun p.prog_funct;
+  List.iter (print_var oc) p.prog_vars;
+  List.iter (print_fundef oc) p.prog_funct
+
diff --git a/powerpc/PrintAsm.mli b/powerpc/PrintAsm.mli
new file mode 100644
index 00000000..aefe3a0a
--- /dev/null
+++ b/powerpc/PrintAsm.mli
@@ -0,0 +1,13 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              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.     *)
+(*                                                                     *)
+(* *********************************************************************)
+
+val print_program: out_channel -> Asm.program -> unit
diff --git a/powerpc/Selection.v b/powerpc/Selection.v
new file mode 100644
index 00000000..1de6ae3c
--- /dev/null
+++ b/powerpc/Selection.v
@@ -0,0 +1,1196 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              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.     *)
+(*                                                                     *)
+(* *********************************************************************)
+
+(** Instruction selection *)
+
+(** The instruction selection pass recognizes opportunities for using
+  combined arithmetic and logical operations and addressing modes
+  offered by the target processor.  For instance, the expression [x + 1]
+  can take advantage of the "immediate add" instruction of the processor,
+  and on the PowerPC, the expression [(x >> 6) & 0xFF] can be turned
+  into a "rotate and mask" instruction.
+
+  Instruction selection proceeds by bottom-up rewriting over expressions.
+  The source language is Cminor and the target language is CminorSel. *)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Mem.
+Require Import Globalenvs.
+Require Cminor.
+Require Import Op.
+Require Import CminorSel.
+
+Infix ":::" := Econs (at level 60, right associativity) : selection_scope.
+
+Open Local Scope selection_scope.
+
+(** * Lifting of let-bound variables *)
+
+(** Some of the instruction functions generate [Elet] constructs to
+  share the evaluation of a subexpression.  Owing to the use of de
+  Bruijn indices for let-bound variables, we need to shift de Bruijn
+  indices when an expression [b] is put in a [Elet a b] context. *)
+
+Fixpoint lift_expr (p: nat) (a: expr) {struct a}: expr :=
+  match a with
+  | Evar id => Evar id
+  | Eop op bl => Eop op (lift_exprlist p bl)
+  | Eload chunk addr bl => Eload chunk addr (lift_exprlist p bl)
+  | Econdition b c d =>
+      Econdition (lift_condexpr p b) (lift_expr p c) (lift_expr p d)
+  | Elet b c => Elet (lift_expr p b) (lift_expr (S p) c)
+  | Eletvar n =>
+      if le_gt_dec p n then Eletvar (S n) else Eletvar n
+  end
+
+with lift_condexpr (p: nat) (a: condexpr) {struct a}: condexpr :=
+  match a with
+  | CEtrue => CEtrue
+  | CEfalse => CEfalse
+  | CEcond cond bl => CEcond cond (lift_exprlist p bl)
+  | CEcondition b c d =>
+      CEcondition (lift_condexpr p b) (lift_condexpr p c) (lift_condexpr p d)
+  end
+
+with lift_exprlist (p: nat) (a: exprlist) {struct a}: exprlist :=
+  match a with
+  | Enil => Enil
+  | Econs b cl => Econs (lift_expr p b) (lift_exprlist p cl)
+  end.
+
+Definition lift (a: expr): expr := lift_expr O a.
+
+(** * Smart constructors for operators *)
+
+(** This section defines functions for building CminorSel expressions
+  and statements, especially expressions consisting of operator
+  applications.  These functions examine their arguments to choose
+  cheaper forms of operators whenever possible.
+
+  For instance, [add e1 e2] will return a CminorSel expression semantically
+  equivalent to [Eop Oadd (e1 ::: e2 ::: Enil)], but will use a
+  [Oaddimm] operator if one of the arguments is an integer constant,
+  or suppress the addition altogether if one of the arguments is the
+  null integer.  In passing, we perform operator reassociation
+  ([(e + c1) * c2] becomes [(e * c2) + (c1 * c2)]) and a small amount
+  of constant propagation.
+*)
+
+(** ** Integer logical negation *)
+
+(** The natural way to write smart constructors is by pattern-matching
+  on their arguments, recognizing cases where cheaper operators
+  or combined operators are applicable.  For instance, integer logical
+  negation has three special cases (not-and, not-or and not-xor),
+  along with a default case that uses not-or over its arguments and itself.
+  This is written naively as follows:
+<<
+Definition notint (e: expr) :=
+  match e with
+  | Eop Oand (t1:::t2:::Enil) => Eop Onand (t1:::t2:::Enil)
+  | Eop Oor (t1:::t2:::Enil) => Eop Onor (t1:::t2:::Enil)
+  | Eop Oxor (t1:::t2:::Enil) => Eop Onxor (t1:::t2:::Enil)
+  | _ => Elet(e, Eop Onor (Eletvar O ::: Eletvar O ::: Enil)
+  end.
+>>
+  However, Coq expands complex pattern-matchings like the above into
+  elementary matchings over all constructors of an inductive type,
+  resulting in much duplication of the final catch-all case.
+  Such duplications generate huge executable code and duplicate
+  cases in the correctness proofs.
+
+  To limit this duplication, we use the following trick due to
+  Yves Bertot.  We first define a dependent inductive type that
+  characterizes the expressions that match each of the 4 cases of interest.
+*)
+
+Inductive notint_cases: forall (e: expr), Set :=
+  | notint_case1:
+      forall (t1: expr) (t2: expr),
+      notint_cases (Eop Oand (t1:::t2:::Enil))
+  | notint_case2:
+      forall (t1: expr) (t2: expr),
+      notint_cases (Eop Oor (t1:::t2:::Enil))
+  | notint_case3:
+      forall (t1: expr) (t2: expr),
+      notint_cases (Eop Oxor (t1:::t2:::Enil))
+  | notint_default:
+      forall (e: expr),
+      notint_cases e.
+
+(** We then define a classification function that takes an expression
+  and return the case in which it falls.  Note that the catch-all case
+  [notint_default] does not state that it is mutually exclusive with
+  the first three, more specific cases.  The classification function
+  nonetheless chooses the specific cases in preference to the catch-all
+  case. *)
+
+Definition notint_match (e: expr) :=
+  match e as z1 return notint_cases z1 with
+  | Eop Oand (t1:::t2:::Enil) =>
+      notint_case1 t1 t2
+  | Eop Oor (t1:::t2:::Enil) =>
+      notint_case2 t1 t2
+  | Eop Oxor (t1:::t2:::Enil) =>
+      notint_case3 t1 t2
+  | e =>
+      notint_default e
+  end.
+
+(** Finally, the [notint] function we need is defined by a 4-case match
+  over the result of the classification function.  Thus, no duplication
+  of the right-hand sides of this match occur, and the proof has only
+  4 cases to consider (it proceeds by case over [notint_match e]).
+  Since the default case is not obviously exclusive with the three
+  specific cases, it is important that its right-hand side is
+  semantically correct for all possible values of [e], which is the
+  case here and for all other smart constructors. *)
+
+Definition notint (e: expr) :=
+  match notint_match e with
+  | notint_case1 t1 t2 =>
+      Eop Onand (t1:::t2:::Enil)
+  | notint_case2 t1 t2 =>
+      Eop Onor (t1:::t2:::Enil)
+  | notint_case3 t1 t2 =>
+      Eop Onxor (t1:::t2:::Enil)
+  | notint_default e =>
+      Elet e (Eop Onor (Eletvar O ::: Eletvar O ::: Enil))
+  end.
+
+(** This programming pattern will be applied systematically for the
+  other smart constructors in this file. *)
+
+(** ** Boolean negation *)
+
+Definition notbool_base (e: expr) :=
+  Eop (Ocmp (Ccompimm Ceq Int.zero)) (e ::: Enil).
+
+Fixpoint notbool (e: expr) {struct e} : expr :=
+  match e with
+  | Eop (Ointconst n) Enil =>
+      Eop (Ointconst (if Int.eq n Int.zero then Int.one else Int.zero)) Enil
+  | Eop (Ocmp cond) args =>
+      Eop (Ocmp (negate_condition cond)) args
+  | Econdition e1 e2 e3 =>
+      Econdition e1 (notbool e2) (notbool e3)
+  | _ =>
+      notbool_base e
+  end.
+
+(** ** Integer addition and pointer addition *)
+
+(*
+Definition addimm (n: int) (e: expr) :=
+  if Int.eq n Int.zero then e else
+  match e with
+  | Eop (Ointconst m) Enil       => Eop (Ointconst(Int.add n m)) Enil
+  | Eop (Oaddrsymbol s m) Enil   => Eop (Oaddrsymbol s (Int.add n m)) Enil
+  | Eop (Oaddrstack m) Enil      => Eop (Oaddrstack (Int.add n m)) Enil
+  | Eop (Oaddimm m) (t ::: Enil) => Eop (Oaddimm(Int.add n m)) (t ::: Enil)
+  | _                            => Eop (Oaddimm n) (e ::: Enil)
+  end.
+*)
+
+(** Addition of an integer constant. *)
+
+Inductive addimm_cases: forall (e: expr), Set :=
+  | addimm_case1:
+      forall (m: int),
+      addimm_cases (Eop (Ointconst m) Enil)
+  | addimm_case2:
+      forall (s: ident) (m: int),
+      addimm_cases (Eop (Oaddrsymbol s m) Enil)
+  | addimm_case3:
+      forall (m: int),
+      addimm_cases (Eop (Oaddrstack m) Enil)
+  | addimm_case4:
+      forall (m: int) (t: expr),
+      addimm_cases (Eop (Oaddimm m) (t ::: Enil))
+  | addimm_default:
+      forall (e: expr),
+      addimm_cases e.
+
+Definition addimm_match (e: expr) :=
+  match e as z1 return addimm_cases z1 with
+  | Eop (Ointconst m) Enil =>
+      addimm_case1 m
+  | Eop (Oaddrsymbol s m) Enil =>
+      addimm_case2 s m
+  | Eop (Oaddrstack m) Enil =>
+      addimm_case3 m
+  | Eop (Oaddimm m) (t ::: Enil) =>
+      addimm_case4 m t
+  | e =>
+      addimm_default e
+  end.
+
+Definition addimm (n: int) (e: expr) :=
+  if Int.eq n Int.zero then e else
+  match addimm_match e with
+  | addimm_case1 m =>
+      Eop (Ointconst(Int.add n m)) Enil
+  | addimm_case2 s m =>
+      Eop (Oaddrsymbol s (Int.add n m)) Enil
+  | addimm_case3 m =>
+      Eop (Oaddrstack (Int.add n m)) Enil
+  | addimm_case4 m t =>
+      Eop (Oaddimm(Int.add n m)) (t ::: Enil)
+  | addimm_default e =>
+      Eop (Oaddimm n) (e ::: Enil)
+  end.
+
+(** Addition of two integer or pointer expressions. *)
+
+(*
+Definition add (e1: expr) (e2: expr) :=
+  match e1, e2 with
+  | Eop (Ointconst n1) Enil, t2 => addimm n1 t2
+  | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil))
+  | Eop(Oaddimm n1) (t1:::Enil)), t2 => addimm n1 (Eop Oadd (t1:::t2:::Enil))
+  | t1, Eop (Ointconst n2) Enil => addimm n2 t1
+  | t1, Eop (Oaddimm n2) (t2:::Enil) => addimm n2 (Eop Oadd (t1:::t2:::Enil))
+  | _, _ => Eop Oadd (e1:::e2:::Enil)
+  end.
+*)
+
+Inductive add_cases: forall (e1: expr) (e2: expr), Set :=
+  | add_case1:
+      forall (n1: int) (t2: expr),
+      add_cases (Eop (Ointconst n1) Enil) (t2)
+  | add_case2:
+      forall (n1: int) (t1: expr) (n2: int) (t2: expr),
+      add_cases (Eop (Oaddimm n1) (t1:::Enil)) (Eop (Oaddimm n2) (t2:::Enil))
+  | add_case3:
+      forall (n1: int) (t1: expr) (t2: expr),
+      add_cases (Eop(Oaddimm n1) (t1:::Enil)) (t2)
+  | add_case4:
+      forall (t1: expr) (n2: int),
+      add_cases (t1) (Eop (Ointconst n2) Enil)
+  | add_case5:
+      forall (t1: expr) (n2: int) (t2: expr),
+      add_cases (t1) (Eop (Oaddimm n2) (t2:::Enil))
+  | add_default:
+      forall (e1: expr) (e2: expr),
+      add_cases e1 e2.
+
+Definition add_match_aux (e1: expr) (e2: expr) :=
+  match e2 as z2 return add_cases e1 z2 with
+  | Eop (Ointconst n2) Enil =>
+      add_case4 e1 n2
+  | Eop (Oaddimm n2) (t2:::Enil) =>
+      add_case5 e1 n2 t2
+  | e2 =>
+      add_default e1 e2
+  end.
+
+Definition add_match (e1: expr) (e2: expr) :=
+  match e1 as z1, e2 as z2 return add_cases z1 z2 with
+  | Eop (Ointconst n1) Enil, t2 =>
+      add_case1 n1 t2
+  | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) =>
+      add_case2 n1 t1 n2 t2
+  | Eop(Oaddimm n1) (t1:::Enil), t2 =>
+      add_case3 n1 t1 t2
+  | e1, e2 =>
+      add_match_aux e1 e2
+  end.
+
+Definition add (e1: expr) (e2: expr) :=
+  match add_match e1 e2 with
+  | add_case1 n1 t2 =>
+      addimm n1 t2
+  | add_case2 n1 t1 n2 t2 =>
+      addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil))
+  | add_case3 n1 t1 t2 =>
+      addimm n1 (Eop Oadd (t1:::t2:::Enil))
+  | add_case4 t1 n2 =>
+      addimm n2 t1
+  | add_case5 t1 n2 t2 =>
+      addimm n2 (Eop Oadd (t1:::t2:::Enil))
+  | add_default e1 e2 =>
+      Eop Oadd (e1:::e2:::Enil)
+  end.
+
+(** ** Integer and pointer subtraction *)
+
+(*
+Definition sub (e1: expr) (e2: expr) :=
+  match e1, e2 with
+  | t1, Eop (Ointconst n2) Enil => addimm (Int.neg n2) t1
+  | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => addimm 
+(intsub n1 n2) (Eop Osub (t1:::t2:::Enil))
+  | Eop (Oaddimm n1) (t1:::Enil), t2 => addimm n1 (Eop Osub (t1:::t2:::Rni
+l))
+  | t1, Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.neg n2) (Eop Osub (t1:::
+:t2:::Enil))
+  | _, _ => Eop Osub (e1:::e2:::Enil)
+  end.
+*)
+
+Inductive sub_cases: forall (e1: expr) (e2: expr), Set :=
+  | sub_case1:
+      forall (t1: expr) (n2: int),
+      sub_cases (t1) (Eop (Ointconst n2) Enil)
+  | sub_case2:
+      forall (n1: int) (t1: expr) (n2: int) (t2: expr),
+      sub_cases (Eop (Oaddimm n1) (t1:::Enil)) (Eop (Oaddimm n2) (t2:::Enil))
+  | sub_case3:
+      forall (n1: int) (t1: expr) (t2: expr),
+      sub_cases (Eop (Oaddimm n1) (t1:::Enil)) (t2)
+  | sub_case4:
+      forall (t1: expr) (n2: int) (t2: expr),
+      sub_cases (t1) (Eop (Oaddimm n2) (t2:::Enil))
+  | sub_default:
+      forall (e1: expr) (e2: expr),
+      sub_cases e1 e2.
+
+Definition sub_match_aux (e1: expr) (e2: expr) :=
+  match e1 as z1 return sub_cases z1 e2 with
+  | Eop (Oaddimm n1) (t1:::Enil) =>
+      sub_case3 n1 t1 e2
+  | e1 =>
+      sub_default e1 e2
+  end.
+
+Definition sub_match (e1: expr) (e2: expr) :=
+  match e2 as z2, e1 as z1 return sub_cases z1 z2 with
+  | Eop (Ointconst n2) Enil, t1 =>
+      sub_case1 t1 n2
+  | Eop (Oaddimm n2) (t2:::Enil), Eop (Oaddimm n1) (t1:::Enil) =>
+      sub_case2 n1 t1 n2 t2
+  | Eop (Oaddimm n2) (t2:::Enil), t1 =>
+      sub_case4 t1 n2 t2
+  | e2, e1 =>
+      sub_match_aux e1 e2
+  end.
+
+Definition sub (e1: expr) (e2: expr) :=
+  match sub_match e1 e2 with
+  | sub_case1 t1 n2 =>
+      addimm (Int.neg n2) t1
+  | sub_case2 n1 t1 n2 t2 =>
+      addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil))
+  | sub_case3 n1 t1 t2 =>
+      addimm n1 (Eop Osub (t1:::t2:::Enil))
+  | sub_case4 t1 n2 t2 =>
+      addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil))
+  | sub_default e1 e2 =>
+      Eop Osub (e1:::e2:::Enil)
+  end.
+
+(** ** Rotates and immediate shifts *)
+
+(*
+Definition rolm (e1: expr) :=
+  match e1 with
+  | Eop (Ointconst n1) Enil =>
+      Eop (Ointconst(Int.and (Int.rol n1 amount2) mask2)) Enil
+  | Eop (Orolm amount1 mask1) (t1:::Enil) =>
+      let amount := Int.and (Int.add amount1 amount2) Ox1Fl in
+      let mask := Int.and (Int.rol mask1 amount2) mask2 in
+      if Int.is_rlw_mask mask
+      then Eop (Orolm amount mask) (t1:::Enil)
+      else Eop (Orolm amount2 mask2) (e1:::Enil)
+  | _ => Eop (Orolm amount2 mask2) (e1:::Enil)
+  end
+*)
+
+Inductive rolm_cases: forall (e1: expr), Set :=
+  | rolm_case1:
+      forall (n1: int),
+      rolm_cases (Eop (Ointconst n1) Enil)
+  | rolm_case2:
+      forall (amount1: int) (mask1: int) (t1: expr),
+      rolm_cases (Eop (Orolm amount1 mask1) (t1:::Enil))
+  | rolm_default:
+      forall (e1: expr),
+      rolm_cases e1.
+
+Definition rolm_match (e1: expr) :=
+  match e1 as z1 return rolm_cases z1 with
+  | Eop (Ointconst n1) Enil =>
+      rolm_case1 n1
+  | Eop (Orolm amount1 mask1) (t1:::Enil) =>
+      rolm_case2 amount1 mask1 t1
+  | e1 =>
+      rolm_default e1
+  end.
+
+Definition rolm (e1: expr) (amount2 mask2: int) :=
+  match rolm_match e1 with
+  | rolm_case1 n1 =>
+      Eop (Ointconst(Int.and (Int.rol n1 amount2) mask2)) Enil
+  | rolm_case2 amount1 mask1 t1 =>
+      let amount := Int.and (Int.add amount1 amount2) (Int.repr 31) in
+      let mask := Int.and (Int.rol mask1 amount2) mask2 in
+      if Int.is_rlw_mask mask
+      then Eop (Orolm amount mask) (t1:::Enil)
+      else Eop (Orolm amount2 mask2) (e1:::Enil)
+  | rolm_default e1 =>
+      Eop (Orolm amount2 mask2) (e1:::Enil)
+  end.
+
+Definition shlimm (e1: expr) (n2: int) :=
+  if Int.eq n2 Int.zero then
+    e1
+  else if Int.ltu n2 (Int.repr 32) then
+    rolm e1 n2 (Int.shl Int.mone n2)
+  else
+    Eop Oshl (e1:::Eop (Ointconst n2) Enil:::Enil).
+
+Definition shruimm (e1: expr) (n2: int) :=
+  if Int.eq n2 Int.zero then
+    e1
+  else if Int.ltu n2 (Int.repr 32) then
+    rolm e1 (Int.sub (Int.repr 32) n2) (Int.shru Int.mone n2)
+  else
+    Eop Oshru (e1:::Eop (Ointconst n2) Enil:::Enil).
+
+(** ** Integer multiply *)
+
+Definition mulimm_base (n1: int) (e2: expr) :=
+  match Int.one_bits n1 with
+  | i :: nil =>
+      shlimm e2 i
+  | i :: j :: nil =>
+      Elet e2
+        (Eop Oadd (shlimm (Eletvar 0) i :::
+                   shlimm (Eletvar 0) j ::: Enil))
+  | _ =>
+      Eop (Omulimm n1) (e2:::Enil)
+  end.
+
+(*
+Definition mulimm (n1: int) (e2: expr) :=
+  if Int.eq n1 Int.zero then 
+    Elet e2 (Eop (Ointconst Int.zero) Enil)
+  else if Int.eq n1 Int.one then
+    e2
+  else match e2 with
+  | Eop (Ointconst n2) Enil => Eop (Ointconst(intmul n1 n2)) Enil
+  | Eop (Oaddimm n2) (t2:::Enil) => addimm (intmul n1 n2) (mulimm_base n1 t2)
+  | _ => mulimm_base n1 e2
+  end.
+*)
+
+Inductive mulimm_cases: forall (e2: expr), Set :=
+  | mulimm_case1:
+      forall (n2: int),
+      mulimm_cases (Eop (Ointconst n2) Enil)
+  | mulimm_case2:
+      forall (n2: int) (t2: expr),
+      mulimm_cases (Eop (Oaddimm n2) (t2:::Enil))
+  | mulimm_default:
+      forall (e2: expr),
+      mulimm_cases e2.
+
+Definition mulimm_match (e2: expr) :=
+  match e2 as z1 return mulimm_cases z1 with
+  | Eop (Ointconst n2) Enil =>
+      mulimm_case1 n2
+  | Eop (Oaddimm n2) (t2:::Enil) =>
+      mulimm_case2 n2 t2
+  | e2 =>
+      mulimm_default e2
+  end.
+
+Definition mulimm (n1: int) (e2: expr) :=
+  if Int.eq n1 Int.zero then 
+    Elet e2 (Eop (Ointconst Int.zero) Enil)
+  else if Int.eq n1 Int.one then
+    e2
+  else match mulimm_match e2 with
+  | mulimm_case1 n2 =>
+      Eop (Ointconst(Int.mul n1 n2)) Enil
+  | mulimm_case2 n2 t2 =>
+      addimm (Int.mul n1 n2) (mulimm_base n1 t2)
+  | mulimm_default e2 =>
+      mulimm_base n1 e2
+  end.
+
+(*
+Definition mul (e1: expr) (e2: expr) :=
+  match e1, e2 with
+  | Eop (Ointconst n1) Enil, t2 => mulimm n1 t2
+  | t1, Eop (Ointconst n2) Enil => mulimm n2 t1
+  | _, _ => Eop Omul (e1:::e2:::Enil)
+  end.
+*)
+
+Inductive mul_cases: forall (e1: expr) (e2: expr), Set :=
+  | mul_case1:
+      forall (n1: int) (t2: expr),
+      mul_cases (Eop (Ointconst n1) Enil) (t2)
+  | mul_case2:
+      forall (t1: expr) (n2: int),
+      mul_cases (t1) (Eop (Ointconst n2) Enil)
+  | mul_default:
+      forall (e1: expr) (e2: expr),
+      mul_cases e1 e2.
+
+Definition mul_match_aux (e1: expr) (e2: expr) :=
+  match e2 as z2 return mul_cases e1 z2 with
+  | Eop (Ointconst n2) Enil =>
+      mul_case2 e1 n2
+  | e2 =>
+      mul_default e1 e2
+  end.
+
+Definition mul_match (e1: expr) (e2: expr) :=
+  match e1 as z1 return mul_cases z1 e2 with
+  | Eop (Ointconst n1) Enil =>
+      mul_case1 n1 e2
+  | e1 =>
+      mul_match_aux e1 e2
+  end.
+
+Definition mul (e1: expr) (e2: expr) :=
+  match mul_match e1 e2 with
+  | mul_case1 n1 t2 =>
+      mulimm n1 t2
+  | mul_case2 t1 n2 =>
+      mulimm n2 t1
+  | mul_default e1 e2 =>
+      Eop Omul (e1:::e2:::Enil)
+  end.
+
+(** ** Integer division and modulus *)
+
+Definition divs (e1: expr) (e2: expr) := Eop Odiv (e1:::e2:::Enil).
+
+Definition mod_aux (divop: operation) (e1 e2: expr) :=
+  Elet e1
+    (Elet (lift e2)
+      (Eop Osub (Eletvar 1 :::
+                 Eop Omul (Eop divop (Eletvar 1 ::: Eletvar 0 ::: Enil) :::
+                           Eletvar 0 :::
+                           Enil) :::
+                 Enil))).
+
+Definition mods := mod_aux Odiv.
+
+Inductive divu_cases: forall (e2: expr), Set :=
+  | divu_case1:
+      forall (n2: int),
+      divu_cases (Eop (Ointconst n2) Enil)
+  | divu_default:
+      forall (e2: expr),
+      divu_cases e2.
+
+Definition divu_match (e2: expr) :=
+  match e2 as z1 return divu_cases z1 with
+  | Eop (Ointconst n2) Enil =>
+      divu_case1 n2
+  | e2 =>
+      divu_default e2
+  end.
+
+Definition divu (e1: expr) (e2: expr) :=
+  match divu_match e2 with
+  | divu_case1 n2 =>
+      match Int.is_power2 n2 with
+      | Some l2 => shruimm e1 l2
+      | None    => Eop Odivu (e1:::e2:::Enil)
+      end
+  | divu_default e2 =>
+      Eop Odivu (e1:::e2:::Enil)
+  end.
+
+Definition modu (e1: expr) (e2: expr) :=
+  match divu_match e2 with
+  | divu_case1 n2 =>
+      match Int.is_power2 n2 with
+      | Some l2 => rolm e1 Int.zero (Int.sub n2 Int.one)
+      | None    => mod_aux Odivu e1 e2
+      end
+  | divu_default e2 =>
+      mod_aux Odivu e1 e2
+  end.
+
+(** ** Bitwise and, or, xor *)
+
+Definition andimm (n1: int) (e2: expr) :=
+  if Int.is_rlw_mask n1
+  then rolm e2 Int.zero n1
+  else Eop (Oandimm n1) (e2:::Enil).
+
+Definition and (e1: expr) (e2: expr) :=
+  match mul_match e1 e2 with
+  | mul_case1 n1 t2 =>
+      andimm n1 t2
+  | mul_case2 t1 n2 =>
+      andimm n2 t1
+  | mul_default e1 e2 =>
+      Eop Oand (e1:::e2:::Enil)
+  end.
+
+Definition same_expr_pure (e1 e2: expr) :=
+  match e1, e2 with
+  | Evar v1, Evar v2 => if ident_eq v1 v2 then true else false
+  | _, _ => false
+  end.
+
+Inductive or_cases: forall (e1: expr) (e2: expr), Set :=
+  | or_case1:
+      forall (amount1: int) (mask1: int) (t1: expr)
+             (amount2: int) (mask2: int) (t2: expr),
+      or_cases (Eop (Orolm amount1  mask1) (t1:::Enil)) 
+               (Eop (Orolm amount2 mask2) (t2:::Enil))
+  | or_default:
+      forall (e1: expr) (e2: expr),
+      or_cases e1 e2.
+
+Definition or_match (e1: expr) (e2: expr) :=
+  match e1 as z1, e2 as z2 return or_cases z1 z2 with
+  | Eop (Orolm amount1  mask1) (t1:::Enil),
+    Eop (Orolm amount2 mask2) (t2:::Enil) =>
+      or_case1 amount1 mask1 t1 amount2 mask2 t2
+  | e1, e2 =>
+      or_default e1 e2
+  end.
+
+Definition or (e1: expr) (e2: expr) :=
+  match or_match e1 e2 with
+  | or_case1 amount1 mask1 t1 amount2 mask2 t2 =>
+      if Int.eq amount1 amount2
+      && Int.is_rlw_mask (Int.or mask1 mask2)
+      && same_expr_pure t1 t2
+      then Eop (Orolm amount1 (Int.or mask1 mask2)) (t1:::Enil)
+      else Eop Oor (e1:::e2:::Enil)
+  | or_default e1 e2 =>
+      Eop Oor (e1:::e2:::Enil)
+  end.
+
+(** ** General shifts *)
+
+Inductive shift_cases: forall (e1: expr), Set :=
+  | shift_case1:
+      forall (n2: int),
+      shift_cases (Eop (Ointconst n2) Enil)
+  | shift_default:
+      forall (e1: expr),
+      shift_cases e1.
+
+Definition shift_match (e1: expr) :=
+  match e1 as z1 return shift_cases z1 with
+  | Eop (Ointconst n2) Enil =>
+      shift_case1 n2
+  | e1 =>
+      shift_default e1
+  end.
+
+Definition shl (e1: expr) (e2: expr) :=
+  match shift_match e2 with
+  | shift_case1 n2 =>
+      shlimm e1 n2
+  | shift_default e2 =>
+      Eop Oshl (e1:::e2:::Enil)
+  end.
+
+Definition shru (e1: expr) (e2: expr) :=
+  match shift_match e2 with
+  | shift_case1 n2 =>
+      shruimm e1 n2
+  | shift_default e2 =>
+      Eop Oshru (e1:::e2:::Enil)
+  end.
+
+(** ** Floating-point arithmetic *)
+
+Parameter use_fused_mul : unit -> bool.
+
+(*
+Definition addf (e1: expr) (e2: expr) :=
+  match e1, e2 with
+  | Eop Omulf (t1:::t2:::Enil), t3 => Eop Omuladdf (t1:::t2:::t3:::Enil)
+  | t1, Eop Omulf (t2:::t3:::Enil) => Elet t1 (Eop Omuladdf (t2:::t3:::Rvar 0:::Enil))
+  | _, _ => Eop Oaddf (e1:::e2:::Enil)
+  end.
+*)
+
+Inductive addf_cases: forall (e1: expr) (e2: expr), Set :=
+  | addf_case1:
+      forall (t1: expr) (t2: expr) (t3: expr),
+      addf_cases (Eop Omulf (t1:::t2:::Enil)) (t3)
+  | addf_case2:
+      forall (t1: expr) (t2: expr) (t3: expr),
+      addf_cases (t1) (Eop Omulf (t2:::t3:::Enil))
+  | addf_default:
+      forall (e1: expr) (e2: expr),
+      addf_cases e1 e2.
+
+Definition addf_match_aux (e1: expr) (e2: expr) :=
+  match e2 as z2 return addf_cases e1 z2 with
+  | Eop Omulf (t2:::t3:::Enil) =>
+      addf_case2 e1 t2 t3
+  | e2 =>
+      addf_default e1 e2
+  end.
+
+Definition addf_match (e1: expr) (e2: expr) :=
+  match e1 as z1 return addf_cases z1 e2 with
+  | Eop Omulf (t1:::t2:::Enil) =>
+      addf_case1 t1 t2 e2
+  | e1 =>
+      addf_match_aux e1 e2
+  end.
+
+Definition addf (e1: expr) (e2: expr) :=
+  if use_fused_mul tt then
+    match addf_match e1 e2 with
+    | addf_case1 t1 t2 t3 =>
+        Eop Omuladdf (t1:::t2:::t3:::Enil)
+    | addf_case2 t1 t2 t3 =>
+        Eop Omuladdf (t2:::t3:::t1:::Enil)
+    | addf_default e1 e2 =>
+        Eop Oaddf (e1:::e2:::Enil)
+    end
+  else Eop Oaddf (e1:::e2:::Enil).
+
+(*
+Definition subf (e1: expr) (e2: expr) :=
+  match e1, e2 with
+  | Eop Omulfloat (t1:::t2:::Enil), t3 => Eop Omulsubf (t1:::t2:::t3:::Enil)
+  | _, _ => Eop Osubf (e1:::e2:::Enil)
+  end.
+*)
+
+Inductive subf_cases: forall (e1: expr) (e2: expr), Set :=
+  | subf_case1:
+      forall (t1: expr) (t2: expr) (t3: expr),
+      subf_cases (Eop Omulf (t1:::t2:::Enil)) (t3)
+  | subf_default:
+      forall (e1: expr) (e2: expr),
+      subf_cases e1 e2.
+
+Definition subf_match (e1: expr) (e2: expr) :=
+  match e1 as z1 return subf_cases z1 e2 with
+  | Eop Omulf (t1:::t2:::Enil) =>
+      subf_case1 t1 t2 e2
+  | e1 =>
+      subf_default e1 e2
+  end.
+
+Definition subf (e1: expr) (e2: expr) :=
+  if use_fused_mul tt then
+    match subf_match e1 e2 with
+    | subf_case1 t1 t2 t3 =>
+        Eop Omulsubf (t1:::t2:::t3:::Enil)
+    | subf_default e1 e2 =>
+        Eop Osubf (e1:::e2:::Enil)
+    end
+  else Eop Osubf (e1:::e2:::Enil).
+
+(** ** Truncations and sign extensions *)
+
+Inductive cast8signed_cases: forall (e1: expr), Set :=
+  | cast8signed_case1:
+      forall (e2: expr),
+      cast8signed_cases (Eop Ocast8signed (e2 ::: Enil))
+  | cast8signed_default:
+      forall (e1: expr),
+      cast8signed_cases e1.
+
+Definition cast8signed_match (e1: expr) :=
+  match e1 as z1 return cast8signed_cases z1 with
+  | Eop Ocast8signed (e2 ::: Enil) =>
+      cast8signed_case1 e2
+  | e1 =>
+      cast8signed_default e1
+  end.
+
+Definition cast8signed (e: expr) := 
+  match cast8signed_match e with
+  | cast8signed_case1 e1 => e
+  | cast8signed_default e1 => Eop Ocast8signed (e1 ::: Enil)
+  end.
+
+Inductive cast8unsigned_cases: forall (e1: expr), Set :=
+  | cast8unsigned_case1:
+      forall (e2: expr),
+      cast8unsigned_cases (Eop Ocast8unsigned (e2 ::: Enil))
+  | cast8unsigned_default:
+      forall (e1: expr),
+      cast8unsigned_cases e1.
+
+Definition cast8unsigned_match (e1: expr) :=
+  match e1 as z1 return cast8unsigned_cases z1 with
+  | Eop Ocast8unsigned (e2 ::: Enil) =>
+      cast8unsigned_case1 e2
+  | e1 =>
+      cast8unsigned_default e1
+  end.
+
+Definition cast8unsigned (e: expr) := 
+  match cast8unsigned_match e with
+  | cast8unsigned_case1 e1 => e
+  | cast8unsigned_default e1 => Eop Ocast8unsigned (e1 ::: Enil)
+  end.
+
+Inductive cast16signed_cases: forall (e1: expr), Set :=
+  | cast16signed_case1:
+      forall (e2: expr),
+      cast16signed_cases (Eop Ocast16signed (e2 ::: Enil))
+  | cast16signed_default:
+      forall (e1: expr),
+      cast16signed_cases e1.
+
+Definition cast16signed_match (e1: expr) :=
+  match e1 as z1 return cast16signed_cases z1 with
+  | Eop Ocast16signed (e2 ::: Enil) =>
+      cast16signed_case1 e2
+  | e1 =>
+      cast16signed_default e1
+  end.
+
+Definition cast16signed (e: expr) := 
+  match cast16signed_match e with
+  | cast16signed_case1 e1 => e
+  | cast16signed_default e1 => Eop Ocast16signed (e1 ::: Enil)
+  end.
+
+Inductive cast16unsigned_cases: forall (e1: expr), Set :=
+  | cast16unsigned_case1:
+      forall (e2: expr),
+      cast16unsigned_cases (Eop Ocast16unsigned (e2 ::: Enil))
+  | cast16unsigned_default:
+      forall (e1: expr),
+      cast16unsigned_cases e1.
+
+Definition cast16unsigned_match (e1: expr) :=
+  match e1 as z1 return cast16unsigned_cases z1 with
+  | Eop Ocast16unsigned (e2 ::: Enil) =>
+      cast16unsigned_case1 e2
+  | e1 =>
+      cast16unsigned_default e1
+  end.
+
+Definition cast16unsigned (e: expr) := 
+  match cast16unsigned_match e with
+  | cast16unsigned_case1 e1 => e
+  | cast16unsigned_default e1 => Eop Ocast16unsigned (e1 ::: Enil)
+  end.
+
+Inductive singleoffloat_cases: forall (e1: expr), Set :=
+  | singleoffloat_case1:
+      forall (e2: expr),
+      singleoffloat_cases (Eop Osingleoffloat (e2 ::: Enil))
+  | singleoffloat_default:
+      forall (e1: expr),
+      singleoffloat_cases e1.
+
+Definition singleoffloat_match (e1: expr) :=
+  match e1 as z1 return singleoffloat_cases z1 with
+  | Eop Osingleoffloat (e2 ::: Enil) =>
+      singleoffloat_case1 e2
+  | e1 =>
+      singleoffloat_default e1
+  end.
+
+Definition singleoffloat (e: expr) := 
+  match singleoffloat_match e with
+  | singleoffloat_case1 e1 => e
+  | singleoffloat_default e1 => Eop Osingleoffloat (e1 ::: Enil)
+  end.
+
+(** ** Comparisons *)
+
+Inductive comp_cases: forall (e1: expr) (e2: expr), Set :=
+  | comp_case1:
+      forall n1 t2,
+      comp_cases (Eop (Ointconst n1) Enil) (t2)
+  | comp_case2:
+      forall t1 n2,
+      comp_cases (t1) (Eop (Ointconst n2) Enil)
+  | comp_default:
+      forall (e1: expr) (e2: expr),
+      comp_cases e1 e2.
+
+Definition comp_match (e1: expr) (e2: expr) :=
+  match e1 as z1, e2 as z2 return comp_cases z1 z2 with
+  | Eop (Ointconst n1) Enil, t2 =>
+      comp_case1 n1 t2
+  | t1, Eop (Ointconst n2) Enil =>
+      comp_case2 t1 n2
+  | e1, e2 =>
+      comp_default e1 e2
+  end.
+
+Definition comp (c: comparison) (e1: expr) (e2: expr) :=
+  match comp_match e1 e2 with
+  | comp_case1 n1 t2 =>
+      Eop (Ocmp (Ccompimm (swap_comparison c) n1)) (t2 ::: Enil)
+  | comp_case2 t1 n2 =>
+      Eop (Ocmp (Ccompimm c n2)) (t1 ::: Enil)
+  | comp_default e1 e2 =>
+      Eop (Ocmp (Ccomp c)) (e1 ::: e2 ::: Enil)
+  end.
+
+Definition compu (c: comparison) (e1: expr) (e2: expr) :=
+  match comp_match e1 e2 with
+  | comp_case1 n1 t2 =>
+      Eop (Ocmp (Ccompuimm (swap_comparison c) n1)) (t2 ::: Enil)
+  | comp_case2 t1 n2 =>
+      Eop (Ocmp (Ccompuimm c n2)) (t1 ::: Enil)
+  | comp_default e1 e2 =>
+      Eop (Ocmp (Ccompu c)) (e1 ::: e2 ::: Enil)
+  end.
+
+Definition compf (c: comparison) (e1: expr) (e2: expr) :=
+  Eop (Ocmp (Ccompf c)) (e1 ::: e2 ::: Enil).
+
+(** ** Conditional expressions *)
+
+Fixpoint negate_condexpr (e: condexpr): condexpr :=
+  match e with
+  | CEtrue => CEfalse
+  | CEfalse => CEtrue
+  | CEcond c el => CEcond (negate_condition c) el
+  | CEcondition e1 e2 e3 =>
+      CEcondition e1 (negate_condexpr e2) (negate_condexpr e3)
+  end.
+
+
+Definition is_compare_neq_zero (c: condition) : bool :=
+  match c with
+  | Ccompimm Cne n => Int.eq n Int.zero
+  | Ccompuimm Cne n => Int.eq n Int.zero
+  | _ => false
+  end.
+
+Definition is_compare_eq_zero (c: condition) : bool :=
+  match c with
+  | Ccompimm Ceq n => Int.eq n Int.zero
+  | Ccompuimm Ceq n => Int.eq n Int.zero
+  | _ => false
+  end.
+
+Fixpoint condexpr_of_expr (e: expr) : condexpr :=
+  match e with
+  | Eop (Ointconst n) Enil =>
+      if Int.eq n Int.zero then CEfalse else CEtrue
+  | Eop (Ocmp c) (e1 ::: Enil) =>
+      if is_compare_neq_zero c then
+        condexpr_of_expr e1
+      else if is_compare_eq_zero c then
+        negate_condexpr (condexpr_of_expr e1)
+      else
+        CEcond c (e1 ::: Enil)
+  | Eop (Ocmp c) el =>
+      CEcond c el
+  | Econdition ce e1 e2 =>
+      CEcondition ce (condexpr_of_expr e1) (condexpr_of_expr e2)
+  | _ =>
+      CEcond (Ccompimm Cne Int.zero) (e:::Enil)
+  end.
+
+(** ** Recognition of addressing modes for load and store operations *)
+
+(*
+Definition addressing (e: expr) :=
+  match e with
+  | Eop (Oaddrsymbol s n) Enil => (Aglobal s n, Enil)
+  | Eop (Oaddrstack n) Enil => (Ainstack n, Enil)
+  | Eop Oadd (Eop (Oaddrsymbol s n) Enil) e2 => (Abased(s, n), e2:::Enil)
+  | Eop (Oaddimm n) (e1:::Enil) => (Aindexed n, e1:::Enil)
+  | Eop Oadd (e1:::e2:::Enil) => (Aindexed2, e1:::e2:::Enil)
+  | _ => (Aindexed Int.zero, e:::Enil)
+  end.
+*)
+
+Inductive addressing_cases: forall (e: expr), Set :=
+  | addressing_case1:
+      forall (s: ident) (n: int),
+      addressing_cases (Eop (Oaddrsymbol s n) Enil)
+  | addressing_case2:
+      forall (n: int),
+      addressing_cases (Eop (Oaddrstack n) Enil)
+  | addressing_case3:
+      forall (s: ident) (n: int) (e2: expr),
+      addressing_cases
+        (Eop Oadd (Eop (Oaddrsymbol s n) Enil:::e2:::Enil))
+  | addressing_case4:
+      forall (n: int) (e1: expr),
+      addressing_cases (Eop (Oaddimm n) (e1:::Enil))
+  | addressing_case5:
+      forall (e1: expr) (e2: expr),
+      addressing_cases (Eop Oadd (e1:::e2:::Enil))
+  | addressing_default:
+      forall (e: expr),
+      addressing_cases e.
+
+Definition addressing_match (e: expr) :=
+  match e as z1 return addressing_cases z1 with
+  | Eop (Oaddrsymbol s n) Enil =>
+      addressing_case1 s n
+  | Eop (Oaddrstack n) Enil =>
+      addressing_case2 n
+  | Eop Oadd (Eop (Oaddrsymbol s n) Enil:::e2:::Enil) =>
+      addressing_case3 s n e2
+  | Eop (Oaddimm n) (e1:::Enil) =>
+      addressing_case4 n e1
+  | Eop Oadd (e1:::e2:::Enil) =>
+      addressing_case5 e1 e2
+  | e =>
+      addressing_default e
+  end.
+
+Definition addressing (e: expr) :=
+  match addressing_match e with
+  | addressing_case1 s n =>
+      (Aglobal s n, Enil)
+  | addressing_case2 n =>
+      (Ainstack n, Enil)
+  | addressing_case3 s n e2 =>
+      (Abased s n, e2:::Enil)
+  | addressing_case4 n e1 =>
+      (Aindexed n, e1:::Enil)
+  | addressing_case5 e1 e2 =>
+      (Aindexed2, e1:::e2:::Enil)
+  | addressing_default e =>
+      (Aindexed Int.zero, e:::Enil)
+  end.
+
+Definition load (chunk: memory_chunk) (e1: expr) :=
+  match addressing e1 with
+  | (mode, args) => Eload chunk mode args
+  end.
+
+Definition store (chunk: memory_chunk) (e1 e2: expr) :=
+  match addressing e1 with
+  | (mode, args) => Sstore chunk mode args e2
+  end.
+
+(** * Translation from Cminor to CminorSel *)
+
+(** Instruction selection for operator applications *)
+
+Definition sel_constant (cst: Cminor.constant) : expr :=
+  match cst with
+  | Cminor.Ointconst n => Eop (Ointconst n) Enil
+  | Cminor.Ofloatconst f => Eop (Ofloatconst f) Enil
+  | Cminor.Oaddrsymbol id ofs => Eop (Oaddrsymbol id ofs) Enil
+  | Cminor.Oaddrstack ofs => Eop (Oaddrstack ofs) Enil
+  end.
+
+Definition sel_unop (op: Cminor.unary_operation) (arg: expr) : expr :=
+  match op with
+  | Cminor.Ocast8unsigned => cast8unsigned arg 
+  | Cminor.Ocast8signed => cast8signed arg 
+  | Cminor.Ocast16unsigned => cast16unsigned arg 
+  | Cminor.Ocast16signed => cast16signed arg 
+  | Cminor.Onegint => Eop (Osubimm Int.zero) (arg ::: Enil)
+  | Cminor.Onotbool => notbool arg
+  | Cminor.Onotint => notint arg
+  | Cminor.Onegf => Eop Onegf (arg ::: Enil)
+  | Cminor.Oabsf => Eop Oabsf (arg ::: Enil)
+  | Cminor.Osingleoffloat => singleoffloat arg
+  | Cminor.Ointoffloat => Eop Ointoffloat (arg ::: Enil)
+  | Cminor.Ointuoffloat => Eop Ointuoffloat (arg ::: Enil)
+  | Cminor.Ofloatofint => Eop Ofloatofint (arg ::: Enil)
+  | Cminor.Ofloatofintu => Eop Ofloatofintu (arg ::: Enil)
+  end.
+
+Definition sel_binop (op: Cminor.binary_operation) (arg1 arg2: expr) : expr :=
+  match op with
+  | Cminor.Oadd => add arg1 arg2
+  | Cminor.Osub => sub arg1 arg2
+  | Cminor.Omul => mul arg1 arg2
+  | Cminor.Odiv => divs arg1 arg2
+  | Cminor.Odivu => divu arg1 arg2
+  | Cminor.Omod => mods arg1 arg2
+  | Cminor.Omodu => modu arg1 arg2
+  | Cminor.Oand => and arg1 arg2
+  | Cminor.Oor => or arg1 arg2
+  | Cminor.Oxor => Eop Oxor (arg1 ::: arg2 ::: Enil)
+  | Cminor.Oshl => shl arg1 arg2
+  | Cminor.Oshr => Eop Oshr (arg1 ::: arg2 ::: Enil)
+  | Cminor.Oshru => shru arg1 arg2
+  | Cminor.Oaddf => addf arg1 arg2
+  | Cminor.Osubf => subf arg1 arg2
+  | Cminor.Omulf => Eop Omulf (arg1 ::: arg2 ::: Enil)
+  | Cminor.Odivf => Eop Odivf (arg1 ::: arg2 ::: Enil)
+  | Cminor.Ocmp c => comp c arg1 arg2
+  | Cminor.Ocmpu c => compu c arg1 arg2
+  | Cminor.Ocmpf c => compf c arg1 arg2
+  end.
+
+(** Conversion from Cminor expression to Cminorsel expressions *)
+
+Fixpoint sel_expr (a: Cminor.expr) : expr :=
+  match a with
+  | Cminor.Evar id => Evar id
+  | Cminor.Econst cst => sel_constant cst
+  | Cminor.Eunop op arg => sel_unop op (sel_expr arg)
+  | Cminor.Ebinop op arg1 arg2 => sel_binop op (sel_expr arg1) (sel_expr arg2)
+  | Cminor.Eload chunk addr => load chunk (sel_expr addr)
+  | Cminor.Econdition cond ifso ifnot =>
+      Econdition (condexpr_of_expr (sel_expr cond))
+                 (sel_expr ifso) (sel_expr ifnot)
+  end.
+
+Fixpoint sel_exprlist (al: list Cminor.expr) : exprlist :=
+  match al with
+  | nil => Enil
+  | a :: bl => Econs (sel_expr a) (sel_exprlist bl)
+  end.
+
+(** Conversion from Cminor statements to Cminorsel statements. *)
+
+Fixpoint sel_stmt (s: Cminor.stmt) : stmt :=
+  match s with
+  | Cminor.Sskip => Sskip
+  | Cminor.Sassign id e => Sassign id (sel_expr e)
+  | Cminor.Sstore chunk addr rhs => store chunk (sel_expr addr) (sel_expr rhs)
+  | Cminor.Scall optid sg fn args =>
+      Scall optid sg (sel_expr fn) (sel_exprlist args)
+  | Cminor.Stailcall sg fn args => 
+      Stailcall sg (sel_expr fn) (sel_exprlist args)
+  | Cminor.Salloc id b => Salloc id (sel_expr b)
+  | Cminor.Sseq s1 s2 => Sseq (sel_stmt s1) (sel_stmt s2)
+  | Cminor.Sifthenelse e ifso ifnot =>
+      Sifthenelse (condexpr_of_expr (sel_expr e))
+                  (sel_stmt ifso) (sel_stmt ifnot)
+  | Cminor.Sloop body => Sloop (sel_stmt body)
+  | Cminor.Sblock body => Sblock (sel_stmt body)
+  | Cminor.Sexit n => Sexit n
+  | Cminor.Sswitch e cases dfl => Sswitch (sel_expr e) cases dfl
+  | Cminor.Sreturn None => Sreturn None
+  | Cminor.Sreturn (Some e) => Sreturn (Some (sel_expr e))
+  | Cminor.Slabel lbl body => Slabel lbl (sel_stmt body)
+  | Cminor.Sgoto lbl => Sgoto lbl
+  end.
+
+(** Conversion of functions and programs. *)
+
+Definition sel_function (f: Cminor.function) : function :=
+  mkfunction
+    f.(Cminor.fn_sig)
+    f.(Cminor.fn_params)
+    f.(Cminor.fn_vars)
+    f.(Cminor.fn_stackspace)
+    (sel_stmt f.(Cminor.fn_body)).
+
+Definition sel_fundef (f: Cminor.fundef) : fundef :=
+  transf_fundef sel_function f.
+
+Definition sel_program (p: Cminor.program) : program :=
+  transform_program sel_fundef p.
+
+
+
diff --git a/powerpc/Selectionproof.v b/powerpc/Selectionproof.v
new file mode 100644
index 00000000..6d629794
--- /dev/null
+++ b/powerpc/Selectionproof.v
@@ -0,0 +1,1398 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              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 of instruction selection *)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Mem.
+Require Import Events.
+Require Import Globalenvs.
+Require Import Smallstep.
+Require Import Cminor.
+Require Import Op.
+Require Import CminorSel.
+Require Import Selection.
+
+Open Local Scope selection_scope.
+
+Section CMCONSTR.
+
+Variable ge: genv.
+Variable sp: val.
+Variable e: env.
+Variable m: mem.
+
+(** * Lifting of let-bound variables *)
+
+Inductive insert_lenv: letenv -> nat -> val -> letenv -> Prop :=
+  | insert_lenv_0:
+      forall le v,
+      insert_lenv le O v (v :: le)
+  | insert_lenv_S:
+      forall le p w le' v,
+      insert_lenv le p w le' ->
+      insert_lenv (v :: le) (S p) w (v :: le').
+
+Lemma insert_lenv_lookup1:
+  forall le p w le',
+  insert_lenv le p w le' ->
+  forall n v,
+  nth_error le n = Some v -> (p > n)%nat ->
+  nth_error le' n = Some v.
+Proof.
+  induction 1; intros.
+  omegaContradiction.
+  destruct n; simpl; simpl in H0. auto. 
+  apply IHinsert_lenv. auto. omega.
+Qed.
+
+Lemma insert_lenv_lookup2:
+  forall le p w le',
+  insert_lenv le p w le' ->
+  forall n v,
+  nth_error le n = Some v -> (p <= n)%nat ->
+  nth_error le' (S n) = Some v.
+Proof.
+  induction 1; intros.
+  simpl. assumption.
+  simpl. destruct n. omegaContradiction. 
+  apply IHinsert_lenv. exact H0. omega.
+Qed.
+
+Hint Resolve eval_Evar eval_Eop eval_Eload eval_Econdition
+             eval_Elet eval_Eletvar 
+             eval_CEtrue eval_CEfalse eval_CEcond
+             eval_CEcondition eval_Enil eval_Econs: evalexpr.
+
+Lemma eval_lift_expr:
+  forall w le a v,
+  eval_expr ge sp e m le a v ->
+  forall p le', insert_lenv le p w le' ->
+  eval_expr ge sp e m le' (lift_expr p a) v.
+Proof.
+  intro w.
+  apply (eval_expr_ind3 ge sp e m
+    (fun le a v =>
+      forall p le', insert_lenv le p w le' ->
+      eval_expr ge sp e m le' (lift_expr p a) v)
+    (fun le a v =>
+      forall p le', insert_lenv le p w le' ->
+      eval_condexpr ge sp e m le' (lift_condexpr p a) v)
+    (fun le al vl =>
+      forall p le', insert_lenv le p w le' ->
+      eval_exprlist ge sp e m le' (lift_exprlist p al) vl));
+  simpl; intros; eauto with evalexpr.
+
+  destruct v1; eapply eval_Econdition;
+  eauto with evalexpr; simpl; eauto with evalexpr.
+
+  eapply eval_Elet. eauto. apply H2. apply insert_lenv_S; auto.
+
+  case (le_gt_dec p n); intro. 
+  apply eval_Eletvar. eapply insert_lenv_lookup2; eauto.
+  apply eval_Eletvar. eapply insert_lenv_lookup1; eauto.
+
+  destruct vb1; eapply eval_CEcondition;
+  eauto with evalexpr; simpl; eauto with evalexpr.
+Qed.
+
+Lemma eval_lift:
+  forall le a v w,
+  eval_expr ge sp e m le a v ->
+  eval_expr ge sp e m (w::le) (lift a) v.
+Proof.
+  intros. unfold lift. eapply eval_lift_expr.
+  eexact H. apply insert_lenv_0. 
+Qed.
+
+Hint Resolve eval_lift: evalexpr.
+
+(** * Useful lemmas and tactics *)
+
+(** The following are trivial lemmas and custom tactics that help
+  perform backward (inversion) and forward reasoning over the evaluation
+  of operator applications. *)  
+
+Ltac EvalOp := eapply eval_Eop; eauto with evalexpr.
+
+Ltac TrivialOp cstr := unfold cstr; intros; EvalOp.
+
+Ltac InvEval1 :=
+  match goal with
+  | [ H: (eval_expr _ _ _ _ _ (Eop _ Enil) _) |- _ ] =>
+      inv H; InvEval1
+  | [ H: (eval_expr _ _ _ _ _ (Eop _ (_ ::: Enil)) _) |- _ ] =>
+      inv H; InvEval1
+  | [ H: (eval_expr _ _ _ _ _ (Eop _ (_ ::: _ ::: Enil)) _) |- _ ] =>
+      inv H; InvEval1
+  | [ H: (eval_exprlist _ _ _ _ _ Enil _) |- _ ] =>
+      inv H; InvEval1
+  | [ H: (eval_exprlist _ _ _ _ _ (_ ::: _) _) |- _ ] =>
+      inv H; InvEval1
+  | _ =>
+      idtac
+  end.
+
+Ltac InvEval2 :=
+  match goal with
+  | [ H: (eval_operation _ _ _ nil _ = Some _) |- _ ] =>
+      simpl in H; inv H
+  | [ H: (eval_operation _ _ _ (_ :: nil) _ = Some _) |- _ ] =>
+      simpl in H; FuncInv
+  | [ H: (eval_operation _ _ _ (_ :: _ :: nil) _ = Some _) |- _ ] =>
+      simpl in H; FuncInv
+  | [ H: (eval_operation _ _ _ (_ :: _ :: _ :: nil) _ = Some _) |- _ ] =>
+      simpl in H; FuncInv
+  | _ =>
+      idtac
+  end.
+
+Ltac InvEval := InvEval1; InvEval2; InvEval2.
+
+(** * Correctness of the smart constructors *)
+
+(** We now show that the code generated by "smart constructor" functions
+  such as [Selection.notint] behaves as expected.  Continuing the
+  [notint] example, we show that if the expression [e]
+  evaluates to some integer value [Vint n], then [Selection.notint e]
+  evaluates to a value [Vint (Int.not n)] which is indeed the integer
+  negation of the value of [e].
+
+  All proofs follow a common pattern:
+- Reasoning by case over the result of the classification functions
+  (such as [add_match] for integer addition), gathering additional
+  information on the shape of the argument expressions in the non-default
+  cases.
+- Inversion of the evaluations of the arguments, exploiting the additional
+  information thus gathered.
+- Equational reasoning over the arithmetic operations performed,
+  using the lemmas from the [Int] and [Float] modules.
+- Construction of an evaluation derivation for the expression returned
+  by the smart constructor.
+*)
+
+Theorem eval_notint:
+  forall le a x,
+  eval_expr ge sp e m le a (Vint x) ->
+  eval_expr ge sp e m le (notint a) (Vint (Int.not x)).
+Proof.
+  unfold notint; intros until x; case (notint_match a); intros; InvEval.
+  EvalOp. simpl. congruence.
+  EvalOp. simpl. congruence.
+  EvalOp. simpl. congruence.
+  eapply eval_Elet. eexact H. 
+  eapply eval_Eop.
+  eapply eval_Econs. apply eval_Eletvar. simpl. reflexivity.
+  eapply eval_Econs. apply eval_Eletvar. simpl. reflexivity.
+  apply eval_Enil.  
+  simpl. rewrite Int.or_idem. auto.
+Qed.
+
+Lemma eval_notbool_base:
+  forall le a v b,
+  eval_expr ge sp e m le a v ->
+  Val.bool_of_val v b ->
+  eval_expr ge sp e m le (notbool_base a) (Val.of_bool (negb b)).
+Proof. 
+  TrivialOp notbool_base. simpl. 
+  inv H0. 
+  rewrite Int.eq_false; auto.
+  rewrite Int.eq_true; auto.
+  reflexivity.
+Qed.
+
+Hint Resolve Val.bool_of_true_val Val.bool_of_false_val
+             Val.bool_of_true_val_inv Val.bool_of_false_val_inv: valboolof.
+
+Theorem eval_notbool:
+  forall le a v b,
+  eval_expr ge sp e m le a v ->
+  Val.bool_of_val v b ->
+  eval_expr ge sp e m le (notbool a) (Val.of_bool (negb b)).
+Proof.
+  induction a; simpl; intros; try (eapply eval_notbool_base; eauto).
+  destruct o; try (eapply eval_notbool_base; eauto).
+
+  destruct e0. InvEval. 
+  inv H0. rewrite Int.eq_false; auto. 
+  simpl; eauto with evalexpr.
+  rewrite Int.eq_true; simpl; eauto with evalexpr.
+  eapply eval_notbool_base; eauto.
+
+  inv H. eapply eval_Eop; eauto.
+  simpl. assert (eval_condition c vl m = Some b).
+  generalize H6. simpl. 
+  case (eval_condition c vl m); intros.
+  destruct b0; inv H1; inversion H0; auto; congruence.
+  congruence.
+  rewrite (Op.eval_negate_condition _ _ _ H). 
+  destruct b; reflexivity.
+
+  inv H. eapply eval_Econdition; eauto. 
+  destruct v1; eauto.
+Qed.
+
+Theorem eval_addimm:
+  forall le n a x,
+  eval_expr ge sp e m le a (Vint x) ->
+  eval_expr ge sp e m le (addimm n a) (Vint (Int.add x n)).
+Proof.
+  unfold addimm; intros until x.
+  generalize (Int.eq_spec n Int.zero). case (Int.eq n Int.zero); intro.
+  subst n. rewrite Int.add_zero. auto.
+  case (addimm_match a); intros; InvEval; EvalOp; simpl.
+  rewrite Int.add_commut. auto.
+  destruct (Genv.find_symbol ge s); discriminate.
+  destruct sp; simpl in H1; discriminate.
+  subst x. rewrite Int.add_assoc. decEq; decEq; decEq. apply Int.add_commut.
+Qed. 
+
+Theorem eval_addimm_ptr:
+  forall le n a b ofs,
+  eval_expr ge sp e m le a (Vptr b ofs) ->
+  eval_expr ge sp e m le (addimm n a) (Vptr b (Int.add ofs n)).
+Proof.
+  unfold addimm; intros until ofs.
+  generalize (Int.eq_spec n Int.zero). case (Int.eq n Int.zero); intro.
+  subst n. rewrite Int.add_zero. auto.
+  case (addimm_match a); intros; InvEval; EvalOp; simpl.
+  destruct (Genv.find_symbol ge s). 
+  rewrite Int.add_commut. congruence.
+  discriminate.
+  destruct sp; simpl in H1; try discriminate.
+  inv H1. simpl. decEq. decEq. 
+  rewrite Int.add_assoc. decEq. apply Int.add_commut.
+  subst. rewrite (Int.add_commut n m0). rewrite Int.add_assoc. auto.
+Qed.
+
+Theorem eval_add:
+  forall le a b x y,
+  eval_expr ge sp e m le a (Vint x) ->
+  eval_expr ge sp e m le b (Vint y) ->
+  eval_expr ge sp e m le (add a b) (Vint (Int.add x y)).
+Proof.
+  intros until y.
+  unfold add; case (add_match a b); intros; InvEval.
+  rewrite Int.add_commut. apply eval_addimm. auto. 
+  replace (Int.add x y) with (Int.add (Int.add i0 i) (Int.add n1 n2)).
+    apply eval_addimm. EvalOp.  
+    subst x; subst y. 
+    repeat rewrite Int.add_assoc. decEq. apply Int.add_permut. 
+  replace (Int.add x y) with (Int.add (Int.add i y) n1).
+    apply eval_addimm. EvalOp.
+    subst x. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut.
+  apply eval_addimm. auto.
+  replace (Int.add x y) with (Int.add (Int.add x i) n2).
+    apply eval_addimm. EvalOp.
+    subst y. rewrite Int.add_assoc. auto.
+  EvalOp.
+Qed.
+
+Theorem eval_add_ptr:
+  forall le a b p x y,
+  eval_expr ge sp e m le a (Vptr p x) ->
+  eval_expr ge sp e m le b (Vint y) ->
+  eval_expr ge sp e m le (add a b) (Vptr p (Int.add x y)).
+Proof.
+  intros until y. unfold add; case (add_match a b); intros; InvEval.
+  replace (Int.add x y) with (Int.add (Int.add i0 i) (Int.add n1 n2)).
+    apply eval_addimm_ptr. subst b0. EvalOp. 
+    subst x; subst y.
+    repeat rewrite Int.add_assoc. decEq. apply Int.add_permut. 
+  replace (Int.add x y) with (Int.add (Int.add i y) n1).
+    apply eval_addimm_ptr. subst b0. EvalOp.
+    subst x. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut.
+  apply eval_addimm_ptr. auto.
+  replace (Int.add x y) with (Int.add (Int.add x i) n2).
+    apply eval_addimm_ptr. EvalOp.
+    subst y. rewrite Int.add_assoc. auto.
+  EvalOp.
+Qed.
+
+Theorem eval_add_ptr_2:
+  forall le a b x p y,
+  eval_expr ge sp e m le a (Vint x) ->
+  eval_expr ge sp e m le b (Vptr p y) ->
+  eval_expr ge sp e m le (add a b) (Vptr p (Int.add y x)).
+Proof.
+  intros until y. unfold add; case (add_match a b); intros; InvEval.
+  apply eval_addimm_ptr. auto.
+  replace (Int.add y x) with (Int.add (Int.add i i0) (Int.add n1 n2)).
+    apply eval_addimm_ptr. subst b0. EvalOp. 
+    subst x; subst y.
+    repeat rewrite Int.add_assoc. decEq. 
+    rewrite (Int.add_commut n1 n2). apply Int.add_permut. 
+  replace (Int.add y x) with (Int.add (Int.add y i) n1).
+    apply eval_addimm_ptr. EvalOp. 
+    subst x. repeat rewrite Int.add_assoc. auto.
+  replace (Int.add y x) with (Int.add (Int.add i x) n2).
+    apply eval_addimm_ptr. EvalOp. subst b0; reflexivity.
+    subst y. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut.
+  EvalOp.
+Qed.
+
+Theorem eval_sub:
+  forall le a b x y,
+  eval_expr ge sp e m le a (Vint x) ->
+  eval_expr ge sp e m le b (Vint y) ->
+  eval_expr ge sp e m le (sub a b) (Vint (Int.sub x y)).
+Proof.
+  intros until y.
+  unfold sub; case (sub_match a b); intros; InvEval.
+  rewrite Int.sub_add_opp. 
+    apply eval_addimm. assumption.
+  replace (Int.sub x y) with (Int.add (Int.sub i0 i) (Int.sub n1 n2)).
+    apply eval_addimm. EvalOp.
+    subst x; subst y.
+    repeat rewrite Int.sub_add_opp.
+    repeat rewrite Int.add_assoc. decEq. 
+    rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr.
+  replace (Int.sub x y) with (Int.add (Int.sub i y) n1).
+    apply eval_addimm. EvalOp.
+    subst x. rewrite Int.sub_add_l. auto.
+  replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)).
+    apply eval_addimm. EvalOp.
+    subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. 
+  EvalOp.
+Qed.
+
+Theorem eval_sub_ptr_int:
+  forall le a b p x y,
+  eval_expr ge sp e m le a (Vptr p x) ->
+  eval_expr ge sp e m le b (Vint y) ->
+  eval_expr ge sp e m le (sub a b) (Vptr p (Int.sub x y)).
+Proof.
+  intros until y.
+  unfold sub; case (sub_match a b); intros; InvEval.
+  rewrite Int.sub_add_opp. 
+    apply eval_addimm_ptr. assumption.
+  subst b0. replace (Int.sub x y) with (Int.add (Int.sub i0 i) (Int.sub n1 n2)).
+    apply eval_addimm_ptr. EvalOp.
+    subst x; subst y.
+    repeat rewrite Int.sub_add_opp.
+    repeat rewrite Int.add_assoc. decEq. 
+    rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr.
+  subst b0. replace (Int.sub x y) with (Int.add (Int.sub i y) n1).
+    apply eval_addimm_ptr. EvalOp.
+    subst x. rewrite Int.sub_add_l. auto.
+  replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)).
+    apply eval_addimm_ptr. EvalOp.
+    subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. 
+  EvalOp.
+Qed.
+
+Theorem eval_sub_ptr_ptr:
+  forall le a b p x y,
+  eval_expr ge sp e m le a (Vptr p x) ->
+  eval_expr ge sp e m le b (Vptr p y) ->
+  eval_expr ge sp e m le (sub a b) (Vint (Int.sub x y)).
+Proof.
+  intros until y.
+  unfold sub; case (sub_match a b); intros; InvEval.
+  replace (Int.sub x y) with (Int.add (Int.sub i0 i) (Int.sub n1 n2)).
+    apply eval_addimm. EvalOp. 
+    simpl; unfold eq_block. subst b0; subst b1; rewrite zeq_true. auto.
+    subst x; subst y.
+    repeat rewrite Int.sub_add_opp.
+    repeat rewrite Int.add_assoc. decEq. 
+    rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr.
+  subst b0. replace (Int.sub x y) with (Int.add (Int.sub i y) n1).
+    apply eval_addimm. EvalOp.
+    simpl. unfold eq_block. rewrite zeq_true. auto.
+    subst x. rewrite Int.sub_add_l. auto.
+  subst b0. replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)).
+    apply eval_addimm. EvalOp.
+    simpl. unfold eq_block. rewrite zeq_true. auto.
+    subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. 
+  EvalOp. simpl. unfold eq_block. rewrite zeq_true. auto.
+Qed.
+
+Lemma eval_rolm:
+  forall le a amount mask x,
+  eval_expr ge sp e m le a (Vint x) ->
+  eval_expr ge sp e m le (rolm a amount mask) (Vint (Int.rolm x amount mask)).
+Proof.
+  intros until x. unfold rolm; case (rolm_match a); intros; InvEval.
+  eauto with evalexpr. 
+  case (Int.is_rlw_mask (Int.and (Int.rol mask1 amount) mask)).
+  EvalOp. simpl. subst x. 
+  decEq. decEq. 
+  replace (Int.and (Int.add amount1 amount) (Int.repr 31))
+     with (Int.modu (Int.add amount1 amount) (Int.repr 32)).
+  symmetry. apply Int.rolm_rolm. 
+  change (Int.repr 31) with (Int.sub (Int.repr 32) Int.one).
+  apply Int.modu_and with (Int.repr 5). reflexivity.
+  EvalOp. econstructor. EvalOp. simpl. rewrite H. reflexivity. constructor. auto.  
+  EvalOp.
+Qed.
+
+Theorem eval_shlimm:
+  forall le a n x,
+  eval_expr ge sp e m le a (Vint x) ->
+  Int.ltu n (Int.repr 32) = true ->
+  eval_expr ge sp e m le (shlimm a n) (Vint (Int.shl x n)).
+Proof.
+  intros.  unfold shlimm.
+  generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro.
+  subst n. rewrite Int.shl_zero. auto.
+  rewrite H0.
+  replace (Int.shl x n) with (Int.rolm x n (Int.shl Int.mone n)).
+  apply eval_rolm. auto. symmetry. apply Int.shl_rolm. exact H0.
+Qed.
+
+Theorem eval_shruimm:
+  forall le a n x,
+  eval_expr ge sp e m le a (Vint x) ->
+  Int.ltu n (Int.repr 32) = true ->
+  eval_expr ge sp e m le (shruimm a n) (Vint (Int.shru x n)).
+Proof.
+  intros.  unfold shruimm.
+  generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro.
+  subst n. rewrite Int.shru_zero. auto.
+  rewrite H0.
+  replace (Int.shru x n) with (Int.rolm x (Int.sub (Int.repr 32) n) (Int.shru Int.mone n)).
+  apply eval_rolm. auto. symmetry. apply Int.shru_rolm. exact H0.
+Qed.
+
+Lemma eval_mulimm_base:
+  forall le a n x,
+  eval_expr ge sp e m le a (Vint x) ->
+  eval_expr ge sp e m le (mulimm_base n a) (Vint (Int.mul x n)).
+Proof.
+  intros; unfold mulimm_base. 
+  generalize (Int.one_bits_decomp n). 
+  generalize (Int.one_bits_range n).
+  change (Z_of_nat wordsize) with 32.
+  destruct (Int.one_bits n).
+  intros. EvalOp. 
+  destruct l.
+  intros. rewrite H1. simpl. 
+  rewrite Int.add_zero. rewrite <- Int.shl_mul.
+  apply eval_shlimm. auto. auto with coqlib. 
+  destruct l.
+  intros. apply eval_Elet with (Vint x). auto.
+  rewrite H1. simpl. rewrite Int.add_zero. 
+  rewrite Int.mul_add_distr_r.
+  rewrite <- Int.shl_mul.
+  rewrite <- Int.shl_mul.
+  EvalOp. eapply eval_Econs. 
+  apply eval_shlimm. apply eval_Eletvar. simpl. reflexivity. 
+  auto with coqlib.
+  eapply eval_Econs.
+  apply eval_shlimm. apply eval_Eletvar. simpl. reflexivity.
+  auto with coqlib.
+  auto with evalexpr.
+  reflexivity.
+  intros. EvalOp. 
+Qed.
+
+Theorem eval_mulimm:
+  forall le a n x,
+  eval_expr ge sp e m le a (Vint x) ->
+  eval_expr ge sp e m le (mulimm n a) (Vint (Int.mul x n)).
+Proof.
+  intros until x; unfold mulimm.
+  generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro.
+  subst n. rewrite Int.mul_zero. 
+  intro. eapply eval_Elet; eauto with evalexpr. 
+  generalize (Int.eq_spec n Int.one); case (Int.eq n Int.one); intro.
+  subst n. rewrite Int.mul_one. auto.
+  case (mulimm_match a); intros; InvEval.
+  EvalOp. rewrite Int.mul_commut. reflexivity.
+  replace (Int.mul x n) with (Int.add (Int.mul i n) (Int.mul n n2)).
+  apply eval_addimm. apply eval_mulimm_base. auto.
+  subst x. rewrite Int.mul_add_distr_l. decEq. apply Int.mul_commut.
+  apply eval_mulimm_base. assumption.
+Qed.
+
+Theorem eval_mul:
+  forall le a b x y,
+  eval_expr ge sp e m le a (Vint x) ->
+  eval_expr ge sp e m le b (Vint y) ->
+  eval_expr ge sp e m le (mul a b) (Vint (Int.mul x y)).
+Proof.
+  intros until y.
+  unfold mul; case (mul_match a b); intros; InvEval.
+  rewrite Int.mul_commut. apply eval_mulimm. auto. 
+  apply eval_mulimm. auto.
+  EvalOp.
+Qed.
+
+Theorem eval_divs:
+  forall le a b x y,
+  eval_expr ge sp e m le a (Vint x) ->
+  eval_expr ge sp e m le b (Vint y) ->
+  y <> Int.zero ->
+  eval_expr ge sp e m le (divs a b) (Vint (Int.divs x y)).
+Proof.
+  TrivialOp divs. simpl. 
+  predSpec Int.eq Int.eq_spec y Int.zero. contradiction. auto.
+Qed.
+
+Lemma eval_mod_aux:
+  forall divop semdivop,
+  (forall sp x y m,
+   y <> Int.zero ->
+   eval_operation ge sp divop (Vint x :: Vint y :: nil) m =
+   Some (Vint (semdivop x y))) ->
+  forall le a b x y,
+  eval_expr ge sp e m le a (Vint x) ->
+  eval_expr ge sp e m le b (Vint y) ->
+  y <> Int.zero ->
+  eval_expr ge sp e m le (mod_aux divop a b)
+   (Vint (Int.sub x (Int.mul (semdivop x y) y))).
+Proof.
+  intros; unfold mod_aux.
+  eapply eval_Elet. eexact H0. eapply eval_Elet. 
+  apply eval_lift. eexact H1.
+  eapply eval_Eop. eapply eval_Econs. 
+  eapply eval_Eletvar. simpl; reflexivity.
+  eapply eval_Econs. eapply eval_Eop. 
+  eapply eval_Econs. eapply eval_Eop.
+  eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity.
+  eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity.
+  apply eval_Enil.  
+  apply H. assumption.
+  eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity.
+  apply eval_Enil.  
+  simpl; reflexivity. apply eval_Enil. 
+  reflexivity.
+Qed.
+
+Theorem eval_mods:
+  forall le a b x y,
+  eval_expr ge sp e m le a (Vint x) ->
+  eval_expr ge sp e m le b (Vint y) ->
+  y <> Int.zero ->
+  eval_expr ge sp e m le (mods a b) (Vint (Int.mods x y)).
+Proof.
+  intros; unfold mods. 
+  rewrite Int.mods_divs. 
+  eapply eval_mod_aux; eauto. 
+  intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero. 
+  contradiction. auto.
+Qed.
+
+Lemma eval_divu_base:
+  forall le a x b y,
+  eval_expr ge sp e m le a (Vint x) ->
+  eval_expr ge sp e m le b (Vint y) ->
+  y <> Int.zero ->
+  eval_expr ge sp e m le (Eop Odivu (a ::: b ::: Enil)) (Vint (Int.divu x y)).
+Proof.
+  intros. EvalOp. simpl. 
+  predSpec Int.eq Int.eq_spec y Int.zero. contradiction. auto.
+Qed.
+
+Theorem eval_divu:
+  forall le a x b y,
+  eval_expr ge sp e m le a (Vint x) ->
+  eval_expr ge sp e m le b (Vint y) ->
+  y <> Int.zero ->
+  eval_expr ge sp e m le (divu a b) (Vint (Int.divu x y)).
+Proof.
+  intros until y.
+  unfold divu; case (divu_match b); intros; InvEval.
+  caseEq (Int.is_power2 y). 
+  intros. rewrite (Int.divu_pow2 x y i H0).
+  apply eval_shruimm. auto.
+  apply Int.is_power2_range with y. auto.
+  intros. apply eval_divu_base. auto. EvalOp. auto.
+  eapply eval_divu_base; eauto.
+Qed.
+
+Theorem eval_modu:
+  forall le a x b y,
+  eval_expr ge sp e m le a (Vint x) ->
+  eval_expr ge sp e m le b (Vint y) ->
+  y <> Int.zero ->
+  eval_expr ge sp e m le (modu a b) (Vint (Int.modu x y)).
+Proof.
+  intros until y; unfold modu; case (divu_match b); intros; InvEval.
+  caseEq (Int.is_power2 y). 
+  intros. rewrite (Int.modu_and x y i H0).
+  rewrite <- Int.rolm_zero. apply eval_rolm. auto.
+  intro. rewrite Int.modu_divu. eapply eval_mod_aux. 
+  intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero.
+  contradiction. auto.
+  auto. EvalOp. auto. auto.
+  rewrite Int.modu_divu. eapply eval_mod_aux. 
+  intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero.
+  contradiction. auto. auto. auto. auto. auto.
+Qed.
+
+Theorem eval_andimm:
+  forall le n a x,
+  eval_expr ge sp e m le a (Vint x) ->
+  eval_expr ge sp e m le (andimm n a) (Vint (Int.and x n)).
+Proof.
+  intros.  unfold andimm. case (Int.is_rlw_mask n).
+  rewrite <- Int.rolm_zero. apply eval_rolm; auto.
+  EvalOp. 
+Qed.
+
+Theorem eval_and:
+  forall le a x b y,
+  eval_expr ge sp e m le a (Vint x) ->
+  eval_expr ge sp e m le b (Vint y) ->
+  eval_expr ge sp e m le (and a b) (Vint (Int.and x y)).
+Proof.
+  intros until y; unfold and; case (mul_match a b); intros; InvEval.
+  rewrite Int.and_commut. apply eval_andimm; auto.
+  apply eval_andimm; auto.
+  EvalOp.
+Qed.
+
+Remark eval_same_expr:
+  forall a1 a2 le v1 v2,
+  same_expr_pure a1 a2 = true ->
+  eval_expr ge sp e m le a1 v1 ->
+  eval_expr ge sp e m le a2 v2 ->
+  a1 = a2 /\ v1 = v2.
+Proof.
+  intros until v2.
+  destruct a1; simpl; try (intros; discriminate). 
+  destruct a2; simpl; try (intros; discriminate).
+  case (ident_eq i i0); intros.
+  subst i0. inversion H0. inversion H1. split. auto. congruence. 
+  discriminate.
+Qed.
+
+Lemma eval_or:
+  forall le a x b y,
+  eval_expr ge sp e m le a (Vint x) ->
+  eval_expr ge sp e m le b (Vint y) ->
+  eval_expr ge sp e m le (or a b) (Vint (Int.or x y)).
+Proof.
+  intros until y; unfold or; case (or_match a b); intros; InvEval.
+  caseEq (Int.eq amount1 amount2 
+          && Int.is_rlw_mask (Int.or mask1 mask2) 
+          && same_expr_pure t1 t2); intro.
+  destruct (andb_prop _ _ H1). destruct (andb_prop _ _ H4).
+  generalize (Int.eq_spec amount1 amount2). rewrite H6. intro. subst amount2.
+  exploit eval_same_expr; eauto. intros [EQ1 EQ2]. inv EQ1. inv EQ2. 
+  simpl. EvalOp. simpl. rewrite Int.or_rolm. auto.
+  simpl. apply eval_Eop with (Vint x :: Vint y :: nil).
+  econstructor. EvalOp. simpl. congruence. 
+  econstructor. EvalOp. simpl. congruence. constructor. auto.
+  EvalOp.
+Qed.
+
+Theorem eval_shl:
+  forall le a x b y,
+  eval_expr ge sp e m le a (Vint x) ->
+  eval_expr ge sp e m le b (Vint y) ->
+  Int.ltu y (Int.repr 32) = true ->
+  eval_expr ge sp e m le (shl a b) (Vint (Int.shl x y)).
+Proof.
+  intros until y; unfold shl; case (shift_match b); intros.
+  InvEval. apply eval_shlimm; auto.
+  EvalOp. simpl. rewrite H1. auto.
+Qed.
+
+Theorem eval_shru:
+  forall le a x b y,
+  eval_expr ge sp e m le a (Vint x) ->
+  eval_expr ge sp e m le b (Vint y) ->
+  Int.ltu y (Int.repr 32) = true ->
+  eval_expr ge sp e m le (shru a b) (Vint (Int.shru x y)).
+Proof.
+  intros until y; unfold shru; case (shift_match b); intros.
+  InvEval. apply eval_shruimm; auto.
+  EvalOp. simpl. rewrite H1. auto.
+Qed.
+
+Theorem eval_addf:
+  forall le a x b y,
+  eval_expr ge sp e m le a (Vfloat x) ->
+  eval_expr ge sp e m le b (Vfloat y) ->
+  eval_expr ge sp e m le (addf a b) (Vfloat (Float.add x y)).
+Proof.
+  intros until y; unfold addf.
+  destruct (use_fused_mul tt).
+  case (addf_match a b); intros; InvEval.
+  EvalOp. simpl. congruence.
+  EvalOp. simpl. rewrite Float.addf_commut. congruence.
+  EvalOp.
+  intros. EvalOp.
+Qed.
+ 
+Theorem eval_subf:
+  forall le a x b y,
+  eval_expr ge sp e m le a (Vfloat x) ->
+  eval_expr ge sp e m le b (Vfloat y) ->
+  eval_expr ge sp e m le (subf a b) (Vfloat (Float.sub x y)).
+Proof.
+  intros until y; unfold subf.
+  destruct (use_fused_mul tt).
+  case (subf_match a b); intros.
+  InvEval. EvalOp. simpl. congruence. 
+  EvalOp.
+  intros. EvalOp.
+Qed.
+
+Theorem eval_cast8signed:
+  forall le a v,
+  eval_expr ge sp e m le a v ->
+  eval_expr ge sp e m le (cast8signed a) (Val.sign_ext 8 v).
+Proof. 
+  intros until v; unfold cast8signed; case (cast8signed_match a); intros; InvEval.
+  EvalOp. simpl. subst v. destruct v1; simpl; auto.
+  rewrite Int.sign_ext_idem. reflexivity. compute; auto.
+  EvalOp.
+Qed.
+
+Theorem eval_cast8unsigned:
+  forall le a v,
+  eval_expr ge sp e m le a v ->
+  eval_expr ge sp e m le (cast8unsigned a) (Val.zero_ext 8 v).
+Proof. 
+  intros until v; unfold cast8unsigned; case (cast8unsigned_match a); intros; InvEval.
+  EvalOp. simpl. subst v. destruct v1; simpl; auto.
+  rewrite Int.zero_ext_idem. reflexivity. compute; auto.
+  EvalOp.
+Qed.
+
+Theorem eval_cast16signed:
+  forall le a v,
+  eval_expr ge sp e m le a v ->
+  eval_expr ge sp e m le (cast16signed a) (Val.sign_ext 16 v).
+Proof. 
+  intros until v; unfold cast16signed; case (cast16signed_match a); intros; InvEval.
+  EvalOp. simpl. subst v. destruct v1; simpl; auto.
+  rewrite Int.sign_ext_idem. reflexivity. compute; auto.
+  EvalOp.
+Qed.
+
+Theorem eval_cast16unsigned:
+  forall le a v,
+  eval_expr ge sp e m le a v ->
+  eval_expr ge sp e m le (cast16unsigned a) (Val.zero_ext 16 v).
+Proof. 
+  intros until v; unfold cast16unsigned; case (cast16unsigned_match a); intros; InvEval.
+  EvalOp. simpl. subst v. destruct v1; simpl; auto.
+  rewrite Int.zero_ext_idem. reflexivity. compute; auto.
+  EvalOp.
+Qed.
+
+Theorem eval_singleoffloat:
+  forall le a v,
+  eval_expr ge sp e m le a v ->
+  eval_expr ge sp e m le (singleoffloat a) (Val.singleoffloat v).
+Proof. 
+  intros until v; unfold singleoffloat; case (singleoffloat_match a); intros; InvEval.
+  EvalOp. simpl. subst v. destruct v1; simpl; auto. rewrite Float.singleoffloat_idem. reflexivity.
+  EvalOp.
+Qed.
+
+Theorem eval_comp_int:
+  forall le c a x b y,
+  eval_expr ge sp e m le a (Vint x) ->
+  eval_expr ge sp e m le b (Vint y) ->
+  eval_expr ge sp e m le (comp c a b) (Val.of_bool(Int.cmp c x y)).
+Proof.
+  intros until y.
+  unfold comp; case (comp_match a b); intros; InvEval.
+  EvalOp. simpl. rewrite Int.swap_cmp. destruct (Int.cmp c x y); reflexivity.
+  EvalOp. simpl. destruct (Int.cmp c x y); reflexivity.
+  EvalOp. simpl. destruct (Int.cmp c x y); reflexivity.
+Qed.
+
+Theorem eval_comp_ptr_int:
+  forall le c a x1 x2 b y v,
+  eval_expr ge sp e m le a (Vptr x1 x2) ->
+  eval_expr ge sp e m le b (Vint y) ->
+  (if Int.eq y Int.zero then Cminor.eval_compare_mismatch c else None) = Some v ->
+  eval_expr ge sp e m le (comp c a b) v.
+Proof.
+  intros until v.
+  unfold comp; case (comp_match a b); intros; InvEval.
+  EvalOp. simpl. destruct (Int.eq y Int.zero); try discriminate.
+  unfold Cminor.eval_compare_mismatch in H1. unfold eval_compare_mismatch.
+  destruct c; try discriminate; auto.
+  EvalOp. simpl. destruct (Int.eq y Int.zero); try discriminate.
+  unfold Cminor.eval_compare_mismatch in H1. unfold eval_compare_mismatch.
+  destruct c; try discriminate; auto.
+Qed.
+
+Theorem eval_comp_int_ptr:
+  forall le c a x b y1 y2 v,
+  eval_expr ge sp e m le a (Vint x) ->
+  eval_expr ge sp e m le b (Vptr y1 y2) ->
+  (if Int.eq x Int.zero then Cminor.eval_compare_mismatch c else None) = Some v ->
+  eval_expr ge sp e m le (comp c a b) v.
+Proof.
+  intros until v.
+  unfold comp; case (comp_match a b); intros; InvEval.
+  EvalOp. simpl. destruct (Int.eq x Int.zero); try discriminate.
+  unfold Cminor.eval_compare_mismatch in H1. unfold eval_compare_mismatch.
+  destruct c; try discriminate; auto.
+  EvalOp. simpl. destruct (Int.eq x Int.zero); try discriminate.
+  unfold Cminor.eval_compare_mismatch in H1. unfold eval_compare_mismatch.
+  destruct c; try discriminate; auto.
+Qed.
+
+Theorem eval_comp_ptr_ptr:
+  forall le c a x1 x2 b y1 y2,
+  eval_expr ge sp e m le a (Vptr x1 x2) ->
+  eval_expr ge sp e m le b (Vptr y1 y2) ->
+  valid_pointer m x1 (Int.signed x2) &&
+  valid_pointer m y1 (Int.signed y2) = true ->
+  x1 = y1 ->
+  eval_expr ge sp e m le (comp c a b) (Val.of_bool(Int.cmp c x2 y2)).
+Proof.
+  intros until y2.
+  unfold comp; case (comp_match a b); intros; InvEval.
+  EvalOp. simpl. rewrite H1. subst y1. rewrite dec_eq_true. 
+  destruct (Int.cmp c x2 y2); reflexivity.
+Qed.
+
+Theorem eval_comp_ptr_ptr_2:
+  forall le c a x1 x2 b y1 y2 v,
+  eval_expr ge sp e m le a (Vptr x1 x2) ->
+  eval_expr ge sp e m le b (Vptr y1 y2) ->
+  valid_pointer m x1 (Int.signed x2) &&
+  valid_pointer m y1 (Int.signed y2) = true ->
+  x1 <> y1 ->
+  Cminor.eval_compare_mismatch c = Some v ->
+  eval_expr ge sp e m le (comp c a b) v.
+Proof.
+  intros until y2.
+  unfold comp; case (comp_match a b); intros; InvEval.
+  EvalOp. simpl. rewrite H1. rewrite dec_eq_false; auto.
+  destruct c; simpl in H3; inv H3; auto.
+Qed.
+
+Theorem eval_compu:
+  forall le c a x b y,
+  eval_expr ge sp e m le a (Vint x) ->
+  eval_expr ge sp e m le b (Vint y) ->
+  eval_expr ge sp e m le (compu c a b) (Val.of_bool(Int.cmpu c x y)).
+Proof.
+  intros until y.
+  unfold compu; case (comp_match a b); intros; InvEval.
+  EvalOp. simpl. rewrite Int.swap_cmpu. destruct (Int.cmpu c x y); reflexivity.
+  EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity.
+  EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity.
+Qed.
+
+Theorem eval_compf:
+  forall le c a x b y,
+  eval_expr ge sp e m le a (Vfloat x) ->
+  eval_expr ge sp e m le b (Vfloat y) ->
+  eval_expr ge sp e m le (compf c a b) (Val.of_bool(Float.cmp c x y)).
+Proof.
+  intros. unfold compf. EvalOp. simpl. 
+  destruct (Float.cmp c x y); reflexivity.
+Qed.
+
+Lemma negate_condexpr_correct:
+  forall le a b,
+  eval_condexpr ge sp e m le a b ->
+  eval_condexpr ge sp e m le (negate_condexpr a) (negb b).
+Proof.
+  induction 1; simpl.
+  constructor.
+  constructor.
+  econstructor. eauto. apply eval_negate_condition. auto.
+  econstructor. eauto. destruct vb1; auto.
+Qed. 
+
+Scheme expr_ind2 := Induction for expr Sort Prop
+  with exprlist_ind2 := Induction for exprlist Sort Prop.
+
+Fixpoint forall_exprlist (P: expr -> Prop) (el: exprlist) {struct el}: Prop :=
+  match el with
+  | Enil => True
+  | Econs e el' => P e /\ forall_exprlist P el'
+  end.
+
+Lemma expr_induction_principle:
+  forall (P: expr -> Prop),
+  (forall i : ident, P (Evar i)) ->
+  (forall (o : operation) (e : exprlist),
+     forall_exprlist P e -> P (Eop o e)) ->
+  (forall (m : memory_chunk) (a : Op.addressing) (e : exprlist),
+     forall_exprlist P e -> P (Eload m a e)) ->
+  (forall (c : condexpr) (e : expr),
+     P e -> forall e0 : expr, P e0 -> P (Econdition c e e0)) ->
+  (forall e : expr, P e -> forall e0 : expr, P e0 -> P (Elet e e0)) ->
+  (forall n : nat, P (Eletvar n)) ->
+  forall e : expr, P e.
+Proof.
+  intros. apply expr_ind2 with (P := P) (P0 := forall_exprlist P); auto.
+  simpl. auto.
+  intros. simpl. auto.
+Qed.
+
+Lemma eval_base_condition_of_expr:
+  forall le a v b,
+  eval_expr ge sp e m le a v ->
+  Val.bool_of_val v b ->
+  eval_condexpr ge sp e m le 
+                (CEcond (Ccompimm Cne Int.zero) (a ::: Enil))
+                b.
+Proof.
+  intros. 
+  eapply eval_CEcond. eauto with evalexpr. 
+  inversion H0; simpl. rewrite Int.eq_false; auto. auto. auto.
+Qed.
+
+Lemma is_compare_neq_zero_correct:
+  forall c v b,
+  is_compare_neq_zero c = true ->
+  eval_condition c (v :: nil) m = Some b ->
+  Val.bool_of_val v b.
+Proof.
+  intros.
+  destruct c; simpl in H; try discriminate;
+  destruct c; simpl in H; try discriminate;
+  generalize (Int.eq_spec i Int.zero); rewrite H; intro; subst i.
+
+  simpl in H0. destruct v; inv H0. 
+  generalize (Int.eq_spec i Int.zero). destruct (Int.eq i Int.zero); intros; simpl.
+  subst i; constructor. constructor; auto. constructor.
+
+  simpl in H0. destruct v; inv H0. 
+  generalize (Int.eq_spec i Int.zero). destruct (Int.eq i Int.zero); intros; simpl.
+  subst i; constructor. constructor; auto.
+Qed.
+
+Lemma is_compare_eq_zero_correct:
+  forall c v b,
+  is_compare_eq_zero c = true ->
+  eval_condition c (v :: nil) m = Some b ->
+  Val.bool_of_val v (negb b).
+Proof.
+  intros. apply is_compare_neq_zero_correct with (negate_condition c).
+  destruct c; simpl in H; simpl; try discriminate;
+  destruct c; simpl; try discriminate; auto.
+  apply eval_negate_condition; auto.
+Qed.
+
+Lemma eval_condition_of_expr:
+  forall a le v b,
+  eval_expr ge sp e m le a v ->
+  Val.bool_of_val v b ->
+  eval_condexpr ge sp e m le (condexpr_of_expr a) b.
+Proof.
+  intro a0; pattern a0.
+  apply expr_induction_principle; simpl; intros;
+    try (eapply eval_base_condition_of_expr; eauto; fail).
+  
+  destruct o; try (eapply eval_base_condition_of_expr; eauto; fail).
+
+  destruct e0. InvEval. 
+  inversion H1. 
+  rewrite Int.eq_false; auto. constructor.
+  subst i; rewrite Int.eq_true. constructor.
+  eapply eval_base_condition_of_expr; eauto.
+
+  inv H0. simpl in H7.
+  assert (eval_condition c vl m = Some b).
+    destruct (eval_condition c vl m); try discriminate.
+    destruct b0; inv H7; inversion H1; congruence.
+  assert (eval_condexpr ge sp e m le (CEcond c e0) b).
+    eapply eval_CEcond; eauto.
+  destruct e0; auto. destruct e1; auto.
+  simpl in H. destruct H.
+  inv H5. inv H11.
+
+  case_eq (is_compare_neq_zero c); intros.
+  eapply H; eauto.
+  apply is_compare_neq_zero_correct with c; auto.
+
+  case_eq (is_compare_eq_zero c); intros.
+  replace b with (negb (negb b)). apply negate_condexpr_correct.
+  eapply H; eauto.
+  apply is_compare_eq_zero_correct with c; auto.
+  apply negb_involutive.
+
+  auto.
+
+  inv H1. destruct v1; eauto with evalexpr.
+Qed.
+
+Lemma eval_addressing:
+  forall le a v b ofs,
+  eval_expr ge sp e m le a v ->
+  v = Vptr b ofs ->
+  match addressing a with (mode, args) =>
+    exists vl,
+    eval_exprlist ge sp e m le args vl /\ 
+    eval_addressing ge sp mode vl = Some v
+  end.
+Proof.
+  intros until v. unfold addressing; case (addressing_match a); intros; InvEval.
+  exists (@nil val). split. eauto with evalexpr. simpl. auto.
+  exists (@nil val). split. eauto with evalexpr. simpl. auto.
+  destruct (Genv.find_symbol ge s); congruence.
+  exists (Vint i0 :: nil). split. eauto with evalexpr. 
+    simpl. destruct (Genv.find_symbol ge s). congruence. discriminate.
+  exists (Vptr b0 i :: nil). split. eauto with evalexpr. 
+    simpl. congruence.
+  exists (Vint i :: Vptr b0 i0 :: nil).
+    split. eauto with evalexpr. simpl. 
+    congruence.
+  exists (Vptr b0 i :: Vint i0 :: nil).
+    split. eauto with evalexpr. simpl. congruence.
+  exists (v :: nil). split. eauto with evalexpr. 
+    subst v. simpl. rewrite Int.add_zero. auto.
+Qed.
+
+Lemma eval_load:
+  forall le a v chunk v',
+  eval_expr ge sp e m le a v ->
+  Mem.loadv chunk m v = Some v' ->
+  eval_expr ge sp e m le (load chunk a) v'.
+Proof.
+  intros. generalize H0; destruct v; simpl; intro; try discriminate.
+  unfold load. 
+  generalize (eval_addressing _ _ _ _ _ H (refl_equal _)).
+  destruct (addressing a). intros [vl [EV EQ]]. 
+  eapply eval_Eload; eauto. 
+Qed.
+
+Lemma eval_store:
+  forall chunk a1 a2 v1 v2 f k m',
+  eval_expr ge sp e m nil a1 v1 ->
+  eval_expr ge sp e m nil a2 v2 ->
+  Mem.storev chunk m v1 v2 = Some m' ->
+  step ge (State f (store chunk a1 a2) k sp e m)
+       E0 (State f Sskip k sp e m').
+Proof.
+  intros. generalize H1; destruct v1; simpl; intro; try discriminate.
+  unfold store.
+  generalize (eval_addressing _ _ _ _ _ H (refl_equal _)).
+  destruct (addressing a1). intros [vl [EV EQ]]. 
+  eapply step_store; eauto. 
+Qed.
+
+(** * Correctness of instruction selection for operators *)
+
+(** We now prove a semantic preservation result for the [sel_unop]
+  and [sel_binop] selection functions.  The proof exploits
+  the results of the previous section. *)
+
+Lemma eval_sel_unop:
+  forall le op a1 v1 v,
+  eval_expr ge sp e m le a1 v1 ->
+  eval_unop op v1 = Some v ->
+  eval_expr ge sp e m le (sel_unop op a1) v.
+Proof.
+  destruct op; simpl; intros; FuncInv; try subst v.
+  apply eval_cast8unsigned; auto.
+  apply eval_cast8signed; auto.
+  apply eval_cast16unsigned; auto.
+  apply eval_cast16signed; auto.
+  EvalOp. 
+  generalize (Int.eq_spec i Int.zero). destruct (Int.eq i Int.zero); intro.
+  change true with (negb false). eapply eval_notbool; eauto. subst i; constructor.
+  change false with (negb true). eapply eval_notbool; eauto. constructor; auto.
+  change Vfalse with (Val.of_bool (negb true)).
+  eapply eval_notbool; eauto. constructor.
+  apply eval_notint; auto.
+  EvalOp.
+  EvalOp.
+  apply eval_singleoffloat; auto.
+  EvalOp.
+  EvalOp.
+  EvalOp.
+  EvalOp.
+Qed.
+
+Lemma eval_sel_binop:
+  forall le op a1 a2 v1 v2 v,
+  eval_expr ge sp e m le a1 v1 ->
+  eval_expr ge sp e m le a2 v2 ->
+  eval_binop op v1 v2 m = Some v ->
+  eval_expr ge sp e m le (sel_binop op a1 a2) v.
+Proof.
+  destruct op; simpl; intros; FuncInv; try subst v.
+  apply eval_add; auto.
+  apply eval_add_ptr_2; auto.
+  apply eval_add_ptr; auto.
+  apply eval_sub; auto.
+  apply eval_sub_ptr_int; auto.
+  destruct (eq_block b b0); inv H1. 
+  eapply eval_sub_ptr_ptr; eauto.
+  apply eval_mul; eauto.
+  generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1.
+  apply eval_divs; eauto.
+  generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1.
+  apply eval_divu; eauto.
+  generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1.
+  apply eval_mods; eauto.
+  generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1.
+  apply eval_modu; eauto.
+  apply eval_and; auto.
+  apply eval_or; auto.
+  EvalOp.
+  caseEq (Int.ltu i0 (Int.repr 32)); intro; rewrite H2 in H1; inv H1.
+  apply eval_shl; auto.
+  EvalOp.
+  caseEq (Int.ltu i0 (Int.repr 32)); intro; rewrite H2 in H1; inv H1.
+  apply eval_shru; auto.
+  apply eval_addf; auto.
+  apply eval_subf; auto.
+  EvalOp.
+  EvalOp.
+  apply eval_comp_int; auto.
+  eapply eval_comp_int_ptr; eauto.
+  eapply eval_comp_ptr_int; eauto.
+  generalize H1; clear H1.
+  case_eq (valid_pointer m b (Int.signed i) && valid_pointer m b0 (Int.signed i0)); intros.
+  destruct (eq_block b b0); inv H2.
+  eapply eval_comp_ptr_ptr; eauto.
+  eapply eval_comp_ptr_ptr_2; eauto.
+  discriminate.
+  eapply eval_compu; eauto.
+  eapply eval_compf; eauto.
+Qed.
+
+End CMCONSTR.
+
+(** * Semantic preservation for instruction selection. *)
+
+Section PRESERVATION.
+
+Variable prog: Cminor.program.
+Let tprog := sel_program prog.
+Let ge := Genv.globalenv prog.
+Let tge := Genv.globalenv tprog.
+
+(** Relationship between the global environments for the original
+  CminorSel program and the generated RTL program. *)
+
+Lemma symbols_preserved:
+  forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
+Proof.
+  intros; unfold ge, tge, tprog, sel_program. 
+  apply Genv.find_symbol_transf.
+Qed.
+
+Lemma functions_translated:
+  forall (v: val) (f: Cminor.fundef),
+  Genv.find_funct ge v = Some f ->
+  Genv.find_funct tge v = Some (sel_fundef f).
+Proof.  
+  intros.
+  exact (Genv.find_funct_transf sel_fundef H).
+Qed.
+
+Lemma function_ptr_translated:
+  forall (b: block) (f: Cminor.fundef),
+  Genv.find_funct_ptr ge b = Some f ->
+  Genv.find_funct_ptr tge b = Some (sel_fundef f).
+Proof.  
+  intros. 
+  exact (Genv.find_funct_ptr_transf sel_fundef H).
+Qed.
+
+Lemma sig_function_translated:
+  forall f,
+  funsig (sel_fundef f) = Cminor.funsig f.
+Proof.
+  intros. destruct f; reflexivity.
+Qed.
+
+(** Semantic preservation for expressions. *)
+
+Lemma sel_expr_correct:
+  forall sp e m a v,
+  Cminor.eval_expr ge sp e m a v ->
+  forall le,
+  eval_expr tge sp e m le (sel_expr a) v.
+Proof.
+  induction 1; intros; simpl.
+  (* Evar *)
+  constructor; auto.
+  (* Econst *)
+  destruct cst; simpl; simpl in H; (econstructor; [constructor|simpl;auto]).
+  rewrite symbols_preserved. auto.
+  (* Eunop *)
+  eapply eval_sel_unop; eauto.
+  (* Ebinop *)
+  eapply eval_sel_binop; eauto.
+  (* Eload *)
+  eapply eval_load; eauto.
+  (* Econdition *)
+  econstructor; eauto. eapply eval_condition_of_expr; eauto. 
+  destruct b1; auto.
+Qed.
+
+Hint Resolve sel_expr_correct: evalexpr.
+
+Lemma sel_exprlist_correct:
+  forall sp e m a v,
+  Cminor.eval_exprlist ge sp e m a v ->
+  forall le,
+  eval_exprlist tge sp e m le (sel_exprlist a) v.
+Proof.
+  induction 1; intros; simpl; constructor; auto with evalexpr.
+Qed.
+
+Hint Resolve sel_exprlist_correct: evalexpr.
+
+(** Semantic preservation for terminating function calls and statements. *)
+
+Fixpoint sel_cont (k: Cminor.cont) : CminorSel.cont :=
+  match k with
+  | Cminor.Kstop => Kstop
+  | Cminor.Kseq s1 k1 => Kseq (sel_stmt s1) (sel_cont k1)
+  | Cminor.Kblock k1 => Kblock (sel_cont k1)
+  | Cminor.Kcall id f sp e k1 =>
+      Kcall id (sel_function f) sp e (sel_cont k1)
+  end.
+
+Inductive match_states: Cminor.state -> CminorSel.state -> Prop :=
+  | match_state: forall f s k s' k' sp e m,
+      s' = sel_stmt s ->
+      k' = sel_cont k ->
+      match_states
+        (Cminor.State f s k sp e m)
+        (State (sel_function f) s' k' sp e m)
+  | match_callstate: forall f args k k' m,
+      k' = sel_cont k ->
+      match_states
+        (Cminor.Callstate f args k m)
+        (Callstate (sel_fundef f) args k' m)
+  | match_returnstate: forall v k k' m,
+      k' = sel_cont k ->
+      match_states
+        (Cminor.Returnstate v k m)
+        (Returnstate v k' m).
+
+Remark call_cont_commut:
+  forall k, call_cont (sel_cont k) = sel_cont (Cminor.call_cont k).
+Proof.
+  induction k; simpl; auto.
+Qed.
+
+Remark find_label_commut:
+  forall lbl s k,
+  find_label lbl (sel_stmt s) (sel_cont k) =
+  option_map (fun sk => (sel_stmt (fst sk), sel_cont (snd sk)))
+             (Cminor.find_label lbl s k).
+Proof.
+  induction s; intros; simpl; auto.
+  unfold store. destruct (addressing (sel_expr e)); auto.
+  change (Kseq (sel_stmt s2) (sel_cont k))
+    with (sel_cont (Cminor.Kseq s2 k)).
+  rewrite IHs1. rewrite IHs2. 
+  destruct (Cminor.find_label lbl s1 (Cminor.Kseq s2 k)); auto.
+  rewrite IHs1. rewrite IHs2. 
+  destruct (Cminor.find_label lbl s1 k); auto.
+  change (Kseq (Sloop (sel_stmt s)) (sel_cont k))
+    with (sel_cont (Cminor.Kseq (Cminor.Sloop s) k)).
+  auto.
+  change (Kblock (sel_cont k))
+    with (sel_cont (Cminor.Kblock k)).
+  auto.
+  destruct o; auto.
+  destruct (ident_eq lbl l); auto.
+Qed.
+
+Lemma sel_step_correct:
+  forall S1 t S2, Cminor.step ge S1 t S2 ->
+  forall T1, match_states S1 T1 ->
+  exists T2, step tge T1 t T2 /\ match_states S2 T2.
+Proof.
+  induction 1; intros T1 ME; inv ME; simpl;
+  try (econstructor; split; [econstructor; eauto with evalexpr | econstructor; eauto]; fail).
+
+  (* skip call *)
+  econstructor; split. 
+  econstructor. destruct k; simpl in H; simpl; auto. 
+  rewrite <- H0; reflexivity.
+  constructor; auto.
+  (* assign *)
+  exists (State (sel_function f) Sskip (sel_cont k) sp (PTree.set id v e) m); split.
+  constructor. auto with evalexpr.
+  constructor; auto.
+  (* store *)
+  econstructor; split.
+  eapply eval_store; eauto with evalexpr.
+  constructor; auto.
+  (* Scall *)
+  econstructor; split.
+  econstructor; eauto with evalexpr.
+  apply functions_translated; eauto. 
+  apply sig_function_translated.
+  constructor; auto.
+  (* Stailcall *)
+  econstructor; split.
+  econstructor; eauto with evalexpr.
+  apply functions_translated; eauto. 
+  apply sig_function_translated.
+  constructor; auto. apply call_cont_commut.
+  (* Salloc *)
+  exists (State (sel_function f) Sskip (sel_cont k) sp (PTree.set id (Vptr b Int.zero) e) m'); split.
+  econstructor; eauto with evalexpr.
+  constructor; auto.
+  (* Sifthenelse *)
+  exists (State (sel_function f) (if b then sel_stmt s1 else sel_stmt s2) (sel_cont k) sp e m); split.
+  constructor. eapply eval_condition_of_expr; eauto with evalexpr.
+  constructor; auto. destruct b; auto.
+  (* Sreturn None *)
+  econstructor; split. 
+  econstructor. rewrite <- H; reflexivity.
+  constructor; auto. apply call_cont_commut.
+  (* Sreturn Some *)
+  econstructor; split. 
+  econstructor. simpl. auto. eauto with evalexpr. 
+  constructor; auto. apply call_cont_commut.
+  (* Sgoto *)
+  econstructor; split.
+  econstructor. simpl. rewrite call_cont_commut. rewrite find_label_commut.
+  rewrite H. simpl. reflexivity. 
+  constructor; auto.
+Qed.
+
+Lemma sel_initial_states:
+  forall S, Cminor.initial_state prog S ->
+  exists R, initial_state tprog R /\ match_states S R.
+Proof.
+  induction 1.
+  econstructor; split.
+  econstructor.
+  simpl. fold tge. rewrite symbols_preserved. eexact H.
+  apply function_ptr_translated. eauto. 
+  rewrite <- H1. apply sig_function_translated; auto.
+  unfold tprog, sel_program. rewrite Genv.init_mem_transf.
+  constructor; auto.
+Qed.
+
+Lemma sel_final_states:
+  forall S R r,
+  match_states S R -> Cminor.final_state S r -> final_state R r.
+Proof.
+  intros. inv H0. inv H. simpl. constructor.
+Qed.
+
+Theorem transf_program_correct:
+  forall (beh: program_behavior),
+  Cminor.exec_program prog beh -> CminorSel.exec_program tprog beh.
+Proof.
+  unfold CminorSel.exec_program, Cminor.exec_program; intros.
+  eapply simulation_step_preservation; eauto.
+  eexact sel_initial_states.
+  eexact sel_final_states.
+  exact sel_step_correct. 
+Qed.
+
+End PRESERVATION.
diff --git a/powerpc/eabi/Conventions.v b/powerpc/eabi/Conventions.v
new file mode 100644
index 00000000..6e27b9d2
--- /dev/null
+++ b/powerpc/eabi/Conventions.v
@@ -0,0 +1,798 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              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.     *)
+(*                                                                     *)
+(* *********************************************************************)
+
+(** Function calling conventions and other conventions regarding the use of 
+    machine registers and stack slots. *)
+
+Require Import Coqlib.
+Require Import AST.
+Require Import Locations.
+
+(** * Classification of machine registers *)
+
+(** Machine registers (type [mreg] in module [Locations]) are divided in
+  the following groups:
+- Temporaries used for spilling, reloading, and parallel move operations.
+- Allocatable registers, that can be assigned to RTL pseudo-registers.
+  These are further divided into:
+-- Callee-save registers, whose value is preserved across a function call.
+-- Caller-save registers that can be modified during a function call.
+
+  We follow the PowerPC/EABI application binary interface (ABI) in our choice
+  of callee- and caller-save registers.
+*)
+
+Definition int_caller_save_regs :=
+  R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: nil.
+
+Definition float_caller_save_regs :=
+  F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: F8 :: F9 :: F10 :: nil.
+
+Definition int_callee_save_regs :=
+  R13 :: R14 :: R15 :: R16 :: R17 :: R18 :: R19 :: R20 :: R21 :: R22 :: 
+  R23 :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 :: R30 :: R31 :: nil.
+
+Definition float_callee_save_regs :=
+  F14 :: F15 :: F16 :: F17 :: F18 :: F19 :: F20 :: F21 :: F22 :: 
+  F23 :: F24 :: F25 :: F26 :: F27 :: F28 :: F29 :: F30 :: F31 :: nil.
+
+Definition destroyed_at_call_regs :=
+  int_caller_save_regs ++ float_caller_save_regs.
+
+Definition destroyed_at_call :=
+  List.map R destroyed_at_call_regs.
+
+Definition int_temporaries := IT1 :: IT2 :: nil.
+
+Definition float_temporaries := FT1 :: FT2 :: FT3 :: nil.
+  
+Definition temporaries := 
+  R IT1 :: R IT2 :: R FT1 :: R FT2 :: R FT3 :: nil.
+
+(** The [index_int_callee_save] and [index_float_callee_save] associate
+  a unique positive integer to callee-save registers.  This integer is
+  used in [Stacking] to determine where to save these registers in
+  the activation record if they are used by the current function. *)
+
+Definition index_int_callee_save (r: mreg) :=
+  match r with
+  | R13 => 0  | R14 => 1  | R15 => 2  | R16 => 3
+  | R17 => 4  | R18 => 5  | R19 => 6  | R20 => 7
+  | R21 => 8  | R22 => 9  | R23 => 10 | R24 => 11
+  | R25 => 12 | R26 => 13 | R27 => 14 | R28 => 15
+  | R29 => 16 | R30 => 17 | R31 => 18 | _ => -1
+  end.
+
+Definition index_float_callee_save (r: mreg) :=
+  match r with
+  | F14 => 0  | F15 => 1  | F16 => 2  | F17 => 3
+  | F18 => 4  | F19 => 5  | F20 => 6  | F21 => 7
+  | F22 => 8  | F23 => 9  | F24 => 10 | F25 => 11
+  | F26 => 12 | F27 => 13 | F28 => 14 | F29 => 15
+  | F30 => 16 | F31 => 17 | _ => -1
+  end.
+
+Ltac ElimOrEq :=
+  match goal with
+  |  |- (?x = ?y) \/ _ -> _ =>
+       let H := fresh in
+       (intro H; elim H; clear H;
+        [intro H; rewrite <- H; clear H | ElimOrEq])
+  |  |- False -> _ =>
+       let H := fresh in (intro H; contradiction)
+  end.
+
+Ltac OrEq :=
+  match goal with
+  | |- (?x = ?x) \/ _ => left; reflexivity
+  | |- (?x = ?y) \/ _ => right; OrEq
+  | |- False => fail
+  end.
+
+Ltac NotOrEq :=
+  match goal with
+  | |- (?x = ?y) \/ _ -> False =>
+       let H := fresh in (
+       intro H; elim H; clear H; [intro; discriminate | NotOrEq])
+  | |- False -> False =>
+       contradiction
+  end.
+
+Lemma index_int_callee_save_pos:
+  forall r, In r int_callee_save_regs -> index_int_callee_save r >= 0.
+Proof.
+  intro r. simpl; ElimOrEq; unfold index_int_callee_save; omega.
+Qed.
+
+Lemma index_float_callee_save_pos:
+  forall r, In r float_callee_save_regs -> index_float_callee_save r >= 0.
+Proof.
+  intro r. simpl; ElimOrEq; unfold index_float_callee_save; omega.
+Qed.
+
+Lemma index_int_callee_save_pos2:
+  forall r, index_int_callee_save r >= 0 -> In r int_callee_save_regs.
+Proof.
+  destruct r; simpl; intro; omegaContradiction || OrEq.
+Qed.
+
+Lemma index_float_callee_save_pos2:
+  forall r, index_float_callee_save r >= 0 -> In r float_callee_save_regs.
+Proof.
+  destruct r; simpl; intro; omegaContradiction || OrEq.
+Qed.
+
+Lemma index_int_callee_save_inj:
+  forall r1 r2, 
+  In r1 int_callee_save_regs ->
+  In r2 int_callee_save_regs ->
+  r1 <> r2 ->
+  index_int_callee_save r1 <> index_int_callee_save r2.
+Proof.
+  intros r1 r2. 
+  simpl; ElimOrEq; ElimOrEq; unfold index_int_callee_save;
+  intros; congruence.
+Qed.
+
+Lemma index_float_callee_save_inj:
+  forall r1 r2, 
+  In r1 float_callee_save_regs ->
+  In r2 float_callee_save_regs ->
+  r1 <> r2 ->
+  index_float_callee_save r1 <> index_float_callee_save r2.
+Proof.
+  intros r1 r2. 
+  simpl; ElimOrEq; ElimOrEq; unfold index_float_callee_save;
+  intros; congruence.
+Qed.
+
+(** The following lemmas show that
+    (temporaries, destroyed at call, integer callee-save, float callee-save)
+    is a partition of the set of machine registers. *)
+
+Lemma int_float_callee_save_disjoint:
+  list_disjoint int_callee_save_regs float_callee_save_regs.
+Proof.
+  red; intros r1 r2. simpl; ElimOrEq; ElimOrEq; discriminate.
+Qed.
+
+Lemma register_classification:
+  forall r, 
+  (In (R r) temporaries \/ In (R r) destroyed_at_call) \/
+  (In r int_callee_save_regs \/ In r float_callee_save_regs).
+Proof.
+  destruct r; 
+  try (left; left; simpl; OrEq);
+  try (left; right; simpl; OrEq);
+  try (right; left; simpl; OrEq);
+  try (right; right; simpl; OrEq).
+Qed.
+
+Lemma int_callee_save_not_destroyed:
+  forall r, 
+    In (R r) temporaries \/ In (R r) destroyed_at_call ->
+    ~(In r int_callee_save_regs).
+Proof.
+  intros; red; intros. elim H.
+  generalize H0. simpl; ElimOrEq; NotOrEq.
+  generalize H0. simpl; ElimOrEq; NotOrEq.
+Qed.
+
+Lemma float_callee_save_not_destroyed:
+  forall r, 
+    In (R r) temporaries \/ In (R r) destroyed_at_call ->
+    ~(In r float_callee_save_regs).
+Proof.
+  intros; red; intros. elim H.
+  generalize H0. simpl; ElimOrEq; NotOrEq.
+  generalize H0. simpl; ElimOrEq; NotOrEq.
+Qed.
+
+Lemma int_callee_save_type:
+  forall r, In r int_callee_save_regs -> mreg_type r = Tint.
+Proof.
+  intro. simpl; ElimOrEq; reflexivity.
+Qed.
+
+Lemma float_callee_save_type:
+  forall r, In r float_callee_save_regs -> mreg_type r = Tfloat.
+Proof.
+  intro. simpl; ElimOrEq; reflexivity.
+Qed.
+
+Ltac NoRepet :=
+  match goal with
+  | |- list_norepet nil =>
+      apply list_norepet_nil
+  | |- list_norepet (?a :: ?b) =>
+      apply list_norepet_cons; [simpl; intuition discriminate | NoRepet]
+  end.
+
+Lemma int_callee_save_norepet:
+  list_norepet int_callee_save_regs.
+Proof.
+  unfold int_callee_save_regs; NoRepet.
+Qed.
+
+Lemma float_callee_save_norepet:
+  list_norepet float_callee_save_regs.
+Proof.
+  unfold float_callee_save_regs; NoRepet.
+Qed.
+
+(** * Acceptable locations for register allocation *)
+
+(** The following predicate describes the locations that can be assigned
+  to an RTL pseudo-register during register allocation: a non-temporary
+  machine register or a [Local] stack slot are acceptable. *)
+
+Definition loc_acceptable (l: loc) : Prop :=
+  match l with
+  | R r => ~(In l temporaries)
+  | S (Local ofs ty) => ofs >= 0
+  | S (Incoming _ _) => False
+  | S (Outgoing _ _) => False
+  end.
+
+Definition locs_acceptable (ll: list loc) : Prop :=
+  forall l, In l ll -> loc_acceptable l.
+
+Lemma temporaries_not_acceptable:
+  forall l, loc_acceptable l -> Loc.notin l temporaries.
+Proof.
+  unfold loc_acceptable; destruct l.
+  simpl. intuition congruence.
+  destruct s; try contradiction. 
+  intro. simpl. tauto.
+Qed.
+Hint Resolve temporaries_not_acceptable: locs.
+
+Lemma locs_acceptable_disj_temporaries:
+  forall ll, locs_acceptable ll -> Loc.disjoint ll temporaries.
+Proof.
+  intros. apply Loc.notin_disjoint. intros.
+  apply temporaries_not_acceptable. auto. 
+Qed.
+
+Lemma loc_acceptable_noteq_diff:
+  forall l1 l2,
+  loc_acceptable l1 -> l1 <> l2 -> Loc.diff l1 l2.
+Proof.
+  unfold loc_acceptable, Loc.diff; destruct l1; destruct l2;
+  try (destruct s); try (destruct s0); intros; auto; try congruence.
+  case (zeq z z0); intro. 
+  compare t t0; intro.
+  subst z0; subst t0; tauto.
+  tauto. tauto.
+  contradiction. contradiction.
+Qed.
+
+Lemma loc_acceptable_notin_notin:
+  forall r ll,
+  loc_acceptable r ->
+  ~(In r ll) -> Loc.notin r ll.
+Proof.
+  induction ll; simpl; intros.
+  auto.
+  split. apply loc_acceptable_noteq_diff. assumption. 
+  apply sym_not_equal. tauto. 
+  apply IHll. assumption. tauto. 
+Qed.
+
+(** * Function calling conventions *)
+
+(** The functions in this section determine the locations (machine registers
+  and stack slots) used to communicate arguments and results between the
+  caller and the callee during function calls.  These locations are functions
+  of the signature of the function and of the call instruction.  
+  Agreement between the caller and the callee on the locations to use
+  is guaranteed by our dynamic semantics for Cminor and RTL, which demand 
+  that the signature of the call instruction is identical to that of the
+  called function.
+
+  Calling conventions are largely arbitrary: they must respect the properties
+  proved in this section (such as no overlapping between the locations
+  of function arguments), but this leaves much liberty in choosing actual
+  locations.  To ensure binary interoperability of code generated by our
+  compiler with libraries compiled by another PowerPC compiler, we
+  implement the standard conventions defined in the PowerPC/EABI
+  application binary interface. *)
+
+(** ** Location of function result *)
+
+(** The result value of a function is passed back to the caller in
+  registers [R3] or [F1], depending on the type of the returned value.
+  We treat a function without result as a function with one integer result. *)
+
+Definition loc_result (s: signature) : mreg :=
+  match s.(sig_res) with
+  | None => R3
+  | Some Tint => R3
+  | Some Tfloat => F1
+  end.
+
+(** The result location has the type stated in the signature. *)
+
+Lemma loc_result_type:
+  forall sig,
+  mreg_type (loc_result sig) =
+  match sig.(sig_res) with None => Tint | Some ty => ty end.
+Proof.
+  intros; unfold loc_result.
+  destruct (sig_res sig). 
+  destruct t; reflexivity.
+  reflexivity.
+Qed.
+
+(** The result location is acceptable. *)
+
+Lemma loc_result_acceptable:
+  forall sig, loc_acceptable (R (loc_result sig)).
+Proof.
+  intros. unfold loc_acceptable. red.
+  unfold loc_result. destruct (sig_res sig).
+  destruct t; simpl; NotOrEq.
+  simpl; NotOrEq.
+Qed.
+
+(** The result location is a caller-save register. *)
+
+Lemma loc_result_caller_save:
+  forall (s: signature), In (R (loc_result s)) destroyed_at_call.
+Proof.
+  intros; unfold loc_result.
+  destruct (sig_res s). 
+  destruct t; simpl; OrEq.
+  simpl; OrEq.
+Qed.
+
+(** The result location is not a callee-save register. *)
+
+Lemma loc_result_not_callee_save:
+  forall (s: signature),
+  ~(In (loc_result s) int_callee_save_regs \/ In (loc_result s) float_callee_save_regs).
+Proof.
+  intros. generalize (loc_result_caller_save s).
+  generalize (int_callee_save_not_destroyed (loc_result s)).
+  generalize (float_callee_save_not_destroyed (loc_result s)).
+  tauto.
+Qed.
+
+(** ** Location of function arguments *)
+
+(** The PowerPC EABI states the following convention for passing arguments
+  to a function:
+- The first 8 integer arguments are passed in registers [R3] to [R10].
+- The first 8 float arguments are passed in registers [F1] to [F8].
+- Extra arguments are passed on the stack, in [Outgoing] slots, consecutively
+  assigned (1 word for an integer argument, 2 words for a float),
+  starting at word offset 0.
+- No stack space is reserved for the arguments that are passed in registers.
+*)
+
+Fixpoint loc_arguments_rec
+    (tyl: list typ) (iregl: list mreg) (fregl: list mreg)
+    (ofs: Z) {struct tyl} : list loc :=
+  match tyl with
+  | nil => nil
+  | Tint :: tys =>
+      match iregl with
+      | nil =>
+          S (Outgoing ofs Tint) :: loc_arguments_rec tys nil fregl (ofs + 1)
+      | ireg :: iregs =>
+          R ireg :: loc_arguments_rec tys iregs fregl ofs
+      end
+  | Tfloat :: tys =>
+      match fregl with
+      | nil =>
+          S (Outgoing ofs Tfloat) :: loc_arguments_rec tys iregl nil (ofs + 2)
+      | freg :: fregs =>
+          R freg :: loc_arguments_rec tys iregl fregs ofs
+      end
+  end.
+
+Definition int_param_regs :=
+  R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: nil.
+Definition float_param_regs :=
+  F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: F8 :: nil.
+
+(** [loc_arguments s] returns the list of locations where to store arguments
+  when calling a function with signature [s].  *)
+
+Definition loc_arguments (s: signature) : list loc :=
+  loc_arguments_rec s.(sig_args) int_param_regs float_param_regs 0.
+
+(** [size_arguments s] returns the number of [Outgoing] slots used
+  to call a function with signature [s]. *)
+
+Fixpoint size_arguments_rec
+    (tyl: list typ) (iregl: list mreg) (fregl: list mreg)
+    (ofs: Z) {struct tyl} : Z :=
+  match tyl with
+  | nil => ofs
+  | Tint :: tys =>
+      match iregl with
+      | nil => size_arguments_rec tys nil fregl (ofs + 1)
+      | ireg :: iregs => size_arguments_rec tys iregs fregl ofs
+      end
+  | Tfloat :: tys =>
+      match fregl with
+      | nil => size_arguments_rec tys iregl nil (ofs + 2)
+      | freg :: fregs => size_arguments_rec tys iregl fregs ofs
+      end
+  end.
+
+Definition size_arguments (s: signature) : Z :=
+  size_arguments_rec s.(sig_args) int_param_regs float_param_regs 0.
+
+(** A tail-call is possible for a signature if the corresponding
+    arguments are all passed in registers. *)
+
+Definition tailcall_possible (s: signature) : Prop :=
+  forall l, In l (loc_arguments s) ->
+  match l with R _ => True | S _ => False end.
+
+(** Argument locations are either non-temporary registers or [Outgoing] 
+  stack slots at nonnegative offsets. *)
+
+Definition loc_argument_acceptable (l: loc) : Prop :=
+  match l with
+  | R r => ~(In l temporaries)
+  | S (Outgoing ofs ty) => ofs >= 0
+  | _ => False
+  end.
+
+Remark loc_arguments_rec_charact:
+  forall tyl iregl fregl ofs l,
+  In l (loc_arguments_rec tyl iregl fregl ofs) ->
+  match l with
+  | R r => In r iregl \/ In r fregl
+  | S (Outgoing ofs' ty) => ofs' >= ofs
+  | S _ => False
+  end.
+Proof.
+  induction tyl; simpl loc_arguments_rec; intros.
+  elim H.
+  destruct a. 
+  destruct iregl; elim H; intro. 
+  subst l. omega.
+  generalize (IHtyl _ _ _ _ H0). destruct l; auto. destruct s; auto. omega.
+  subst l. auto with coqlib.
+  generalize (IHtyl _ _ _ _ H0). destruct l; auto. simpl; intuition.
+  destruct fregl; elim H; intro. 
+  subst l. omega.
+  generalize (IHtyl _ _ _ _ H0). destruct l; auto. destruct s; auto. omega.
+  subst l. auto with coqlib.
+  generalize (IHtyl _ _ _ _ H0). destruct l; auto.
+  intros [A|B]. left; auto. right; auto with coqlib.
+Qed.
+
+Lemma loc_arguments_acceptable:
+  forall (s: signature) (r: loc),
+  In r (loc_arguments s) -> loc_argument_acceptable r.
+Proof.
+  unfold loc_arguments; intros.
+  generalize (loc_arguments_rec_charact _ _ _ _ _ H).
+  destruct r.
+  intro H0; elim H0. simpl. unfold not. ElimOrEq; NotOrEq.
+  simpl. unfold not. ElimOrEq; NotOrEq.
+  destruct s0; try contradiction.
+  simpl. omega. 
+Qed. 
+Hint Resolve loc_arguments_acceptable: locs.
+
+(** Arguments are parwise disjoint (in the sense of [Loc.norepet]). *)
+
+Remark loc_arguments_rec_notin_reg:
+  forall tyl iregl fregl ofs r,
+  ~(In r iregl) -> ~(In r fregl) ->
+  Loc.notin (R r) (loc_arguments_rec tyl iregl fregl ofs).
+Proof.
+  induction tyl; simpl; intros.
+  auto.
+  destruct a. 
+  destruct iregl; simpl. auto.
+  simpl in H. split. apply sym_not_equal. tauto.
+  apply IHtyl. tauto. tauto.
+  destruct fregl; simpl. auto.
+  simpl in H0. split. apply sym_not_equal. tauto.
+  apply IHtyl. 
+  red; intro. apply H. auto.
+  tauto.
+Qed.
+
+Remark loc_arguments_rec_notin_local:
+  forall tyl iregl fregl ofs ofs0 ty0,
+  Loc.notin (S (Local ofs0 ty0)) (loc_arguments_rec tyl iregl fregl ofs).
+Proof.
+  induction tyl; simpl; intros.
+  auto.
+  destruct a.
+  destruct iregl; simpl; auto.
+  destruct fregl; simpl; auto.
+Qed.
+
+Remark loc_arguments_rec_notin_outgoing:
+  forall tyl iregl fregl ofs ofs0 ty0,
+  ofs0 + typesize ty0 <= ofs ->
+  Loc.notin (S (Outgoing ofs0 ty0)) (loc_arguments_rec tyl iregl fregl ofs).
+Proof.
+  induction tyl; simpl; intros.
+  auto.
+  destruct a.
+  destruct iregl; simpl. 
+  split. omega. eapply IHtyl. omega.
+  auto.
+  destruct fregl; simpl. 
+  split. omega. eapply IHtyl. omega.
+  auto.
+Qed.
+
+Lemma loc_arguments_norepet:
+  forall (s: signature), Loc.norepet (loc_arguments s).
+Proof.
+  assert (forall tyl iregl fregl ofs,
+    list_norepet iregl ->
+    list_norepet fregl ->
+    list_disjoint iregl fregl ->
+    Loc.norepet (loc_arguments_rec tyl iregl fregl ofs)).
+  induction tyl; simpl; intros.
+  constructor.
+  destruct a. 
+  destruct iregl; constructor.
+  apply loc_arguments_rec_notin_outgoing. simpl; omega. auto.
+  apply loc_arguments_rec_notin_reg. inversion H. auto.
+  apply list_disjoint_notin with (m :: iregl); auto with coqlib.
+  apply IHtyl. inv H; auto. auto.
+  eapply list_disjoint_cons_left; eauto.
+  destruct fregl; constructor.
+  apply loc_arguments_rec_notin_outgoing. simpl; omega. auto.
+  apply loc_arguments_rec_notin_reg.
+  red; intro. apply (H1 m m). auto. 
+  auto with coqlib. auto. inv H0; auto.
+  apply IHtyl. auto.
+  inv H0; auto. 
+  red; intros. apply H1. auto. auto with coqlib.
+
+  intro. unfold loc_arguments. apply H.
+  unfold int_param_regs. NoRepet.
+  unfold float_param_regs. NoRepet.
+  red; intros x y; simpl. ElimOrEq; ElimOrEq; discriminate.
+Qed.
+
+(** The offsets of [Outgoing] arguments are below [size_arguments s]. *)
+
+Remark size_arguments_rec_above:
+  forall tyl iregl fregl ofs0,
+  ofs0 <= size_arguments_rec tyl iregl fregl ofs0.
+Proof.
+  induction tyl; simpl; intros.
+  omega.
+  destruct a.
+  destruct iregl. apply Zle_trans with (ofs0 + 1); auto; omega. auto.
+  destruct fregl. apply Zle_trans with (ofs0 + 2); auto; omega. auto.
+Qed.
+
+Lemma size_arguments_above:
+  forall s, size_arguments s >= 0.
+Proof.
+  intros; unfold size_arguments. apply Zle_ge.  
+  apply size_arguments_rec_above.
+Qed.
+
+Lemma loc_arguments_bounded:
+  forall (s: signature) (ofs: Z) (ty: typ),
+  In (S (Outgoing ofs ty)) (loc_arguments s) ->
+  ofs + typesize ty <= size_arguments s.
+Proof.
+  intros.
+  assert (forall tyl iregl fregl ofs0,
+    In (S (Outgoing ofs ty)) (loc_arguments_rec tyl iregl fregl ofs0) ->
+    ofs + typesize ty <= size_arguments_rec tyl iregl fregl ofs0).
+  induction tyl; simpl; intros.
+  elim H0.
+  destruct a. destruct iregl; elim H0; intro.
+  inv H1. simpl. apply size_arguments_rec_above. auto.
+  discriminate. auto. 
+  destruct fregl; elim H0; intro.
+  inv H1. simpl. apply size_arguments_rec_above. auto.
+  discriminate. auto. 
+  unfold size_arguments. eapply H0. unfold loc_arguments in H. eauto.
+Qed.
+
+(** Temporary registers do not overlap with argument locations. *)
+
+Lemma loc_arguments_not_temporaries:
+  forall sig, Loc.disjoint (loc_arguments sig) temporaries.
+Proof.
+  intros; red; intros x1 x2 H.
+  generalize (loc_arguments_rec_charact _ _ _ _ _ H).
+  destruct x1. 
+  intro H0; elim H0; simpl; (ElimOrEq; ElimOrEq; congruence).
+  destruct s; try contradiction. intro.
+  simpl; ElimOrEq; auto.
+Qed.
+Hint Resolve loc_arguments_not_temporaries: locs.
+
+(** Argument registers are caller-save. *)
+
+Lemma arguments_caller_save:
+  forall sig r,
+  In (R r) (loc_arguments sig) -> In (R r) destroyed_at_call.
+Proof.
+  unfold loc_arguments; intros.
+  elim (loc_arguments_rec_charact _ _ _ _ _ H); simpl.
+  ElimOrEq; intuition.
+  ElimOrEq; intuition.
+Qed.
+
+(** Callee-save registers do not overlap with argument locations. *)
+
+Lemma arguments_not_preserved:
+  forall sig l,
+  Loc.notin l destroyed_at_call -> loc_acceptable l ->
+  Loc.notin l (loc_arguments sig).
+Proof.
+  intros. unfold loc_arguments. destruct l.
+  apply loc_arguments_rec_notin_reg. 
+  generalize (Loc.notin_not_in _ _ H). intro; red; intro.
+  apply H1. generalize H2. simpl. ElimOrEq; OrEq. 
+  generalize (Loc.notin_not_in _ _ H). intro; red; intro.
+  apply H1. generalize H2. simpl. ElimOrEq; OrEq. 
+  destruct s; simpl in H0; try contradiction.
+  apply loc_arguments_rec_notin_local.
+Qed.
+Hint Resolve arguments_not_preserved: locs.
+
+(** Argument locations agree in number with the function signature. *)
+
+Lemma loc_arguments_length:
+  forall sig,
+  List.length (loc_arguments sig) = List.length sig.(sig_args).
+Proof.
+  assert (forall tyl iregl fregl ofs,
+    List.length (loc_arguments_rec tyl iregl fregl ofs) = List.length tyl).
+  induction tyl; simpl; intros.
+  auto.
+  destruct a. 
+  destruct iregl; simpl; decEq; auto.
+  destruct fregl; simpl; decEq; auto.
+  intros. unfold loc_arguments. auto.
+Qed.
+
+(** Argument locations agree in types with the function signature. *)
+
+Lemma loc_arguments_type:
+  forall sig, List.map Loc.type (loc_arguments sig) = sig.(sig_args).
+Proof.
+  assert (forall tyl iregl fregl ofs,
+    (forall r, In r iregl -> mreg_type r = Tint) ->
+    (forall r, In r fregl -> mreg_type r = Tfloat) ->
+    List.map Loc.type (loc_arguments_rec tyl iregl fregl ofs) = tyl).
+  induction tyl; simpl; intros.
+  auto.
+  destruct a; [destruct iregl|destruct fregl]; simpl;
+  f_equal; eauto with coqlib.
+
+  intros. unfold loc_arguments. apply H. 
+  intro; simpl. ElimOrEq; reflexivity.
+  intro; simpl. ElimOrEq; reflexivity.
+Qed.
+
+(** There is no partial overlap between an argument location and an
+  acceptable location: they are either identical or disjoint. *)
+
+Lemma no_overlap_arguments:
+  forall args sg,
+  locs_acceptable args ->
+  Loc.no_overlap args (loc_arguments sg).
+Proof.
+  unfold Loc.no_overlap; intros.
+  generalize (H r H0).
+  generalize (loc_arguments_acceptable _ _ H1).
+  destruct s; destruct r; simpl.
+  intros. case (mreg_eq m0 m); intro. left; congruence. tauto.
+  intros. right; destruct s; auto.
+  intros. right. auto.
+  destruct s; try tauto. destruct s0; tauto.
+Qed.
+
+(** Decide whether a tailcall is possible. *)
+
+Definition tailcall_is_possible (sg: signature) : bool :=
+  let fix tcisp (l: list loc) :=
+    match l with
+    | nil => true
+    | R _ :: l' => tcisp l'
+    | S _ :: l' => false
+    end
+  in tcisp (loc_arguments sg).
+
+Lemma tailcall_is_possible_correct:
+  forall s, tailcall_is_possible s = true -> tailcall_possible s.
+Proof.
+  intro s. unfold tailcall_is_possible, tailcall_possible.
+  generalize (loc_arguments s). induction l; simpl; intros.
+  elim H0.
+  destruct a. 
+  destruct H0. subst l0. auto. apply IHl. auto. auto. discriminate.
+Qed.
+
+(** ** Location of function parameters *)
+
+(** A function finds the values of its parameter in the same locations
+  where its caller stored them, except that the stack-allocated arguments,
+  viewed as [Outgoing] slots by the caller, are accessed via [Incoming]
+  slots (at the same offsets and types) in the callee. *)
+
+Definition parameter_of_argument (l: loc) : loc :=
+  match l with
+  | S (Outgoing n ty) => S (Incoming n ty)
+  | _ => l
+  end.
+
+Definition loc_parameters (s: signature) :=
+  List.map parameter_of_argument (loc_arguments s).
+
+Lemma loc_parameters_type:
+  forall sig, List.map Loc.type (loc_parameters sig) = sig.(sig_args).
+Proof.
+  intros. unfold loc_parameters.
+  rewrite list_map_compose. 
+  rewrite <- loc_arguments_type.
+  apply list_map_exten.
+  intros. destruct x; simpl. auto. 
+  destruct s; reflexivity.
+Qed.
+
+Lemma loc_parameters_length:
+  forall sg, List.length (loc_parameters sg) = List.length sg.(sig_args).
+Proof.
+  intros. unfold loc_parameters. rewrite list_length_map. 
+  apply loc_arguments_length.
+Qed.
+
+Lemma loc_parameters_not_temporaries:
+  forall sig, Loc.disjoint (loc_parameters sig) temporaries.
+Proof.
+  intro; red; intros.
+  unfold loc_parameters in H. 
+  elim (list_in_map_inv _ _ _ H). intros y [EQ IN].
+  generalize (loc_arguments_not_temporaries sig y x2 IN H0).
+  subst x1. destruct x2.
+  destruct y; simpl. auto. destruct s; auto.
+  byContradiction. generalize H0. simpl. NotOrEq.
+Qed.
+
+Lemma no_overlap_parameters:
+  forall params sg,
+  locs_acceptable params ->
+  Loc.no_overlap (loc_parameters sg) params.
+Proof.
+  unfold Loc.no_overlap; intros.
+  unfold loc_parameters in H0. 
+  elim (list_in_map_inv _ _ _ H0). intros t [EQ IN].
+  rewrite EQ. 
+  generalize (loc_arguments_acceptable _ _ IN).
+  generalize (H s H1).
+  destruct s; destruct t; simpl.
+  intros. case (mreg_eq m0 m); intro. left; congruence. tauto.
+  intros. right; destruct s; simpl; auto.
+  intros; right; auto.
+  destruct s; try tauto. destruct s0; try tauto. 
+  intros; simpl. tauto.
+Qed.
+
+(** ** Location of argument and result for dynamic memory allocation *)
+
+Definition loc_alloc_argument := R3.
+Definition loc_alloc_result := R3.
diff --git a/powerpc/eabi/Stacklayout.v b/powerpc/eabi/Stacklayout.v
new file mode 100644
index 00000000..f641847e
--- /dev/null
+++ b/powerpc/eabi/Stacklayout.v
@@ -0,0 +1,79 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              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.     *)
+(*                                                                     *)
+(* *********************************************************************)
+
+(** Machine- and ABI-dependent layout information for activation records. *)
+
+Require Import Coqlib.
+Require Import Bounds.
+
+(** In the PowerPC/EABI application binary interface,
+  the general shape of activation records is as follows,
+  from bottom (lowest offsets) to top:
+- 8 reserved bytes.  The first 4 bytes hold the back pointer to the
+  activation record of the caller.  The next 4 bytes hold the
+  return address.
+- Space for outgoing arguments to function calls.
+- Local stack slots of integer type.
+- Saved values of integer callee-save registers used by the function.
+- One word of padding, if necessary to align the following data
+  on a 8-byte boundary.
+- Local stack slots of float type.
+- Saved values of float callee-save registers used by the function.
+- Space for the stack-allocated data declared in Cminor.
+
+To facilitate some of the proofs, the Cminor stack-allocated data
+starts at offset 0; the preceding areas in the activation record
+therefore have negative offsets.  This part (with negative offsets)
+is called the ``frame'', by opposition with the ``Cminor stack data''
+which is the part with positive offsets.
+
+The [frame_env] compilation environment records the positions of
+the boundaries between areas in the frame part.
+*)
+
+Definition fe_ofs_arg := 8.
+
+Record frame_env : Set := mk_frame_env {
+  fe_size: Z;
+  fe_ofs_link: Z;
+  fe_ofs_retaddr: Z;
+  fe_ofs_int_local: Z;
+  fe_ofs_int_callee_save: Z;
+  fe_num_int_callee_save: Z;
+  fe_ofs_float_local: Z;
+  fe_ofs_float_callee_save: Z;
+  fe_num_float_callee_save: Z
+}.
+
+(** Computation of the frame environment from the bounds of the current
+  function. *)
+
+Definition make_env (b: bounds) :=
+  let oil := 8 + 4 * b.(bound_outgoing) in    (* integer locals *)
+  let oics := oil + 4 * b.(bound_int_local) in (* integer callee-saves *)
+  let oendi := oics + 4 * b.(bound_int_callee_save) in
+  let ofl := align oendi 8 in       (* float locals *)
+  let ofcs := ofl + 8 * b.(bound_float_local) in (* float callee-saves *)
+  let sz := ofcs + 8 * b.(bound_float_callee_save) in (* total frame size *)
+  mk_frame_env sz 0 4
+                  oil oics b.(bound_int_callee_save)
+                  ofl ofcs b.(bound_float_callee_save).
+
+
+Remark align_float_part:
+  forall b,
+  8 + 4 * bound_outgoing b + 4 * bound_int_local b + 4 * bound_int_callee_save b <=
+  align (8 + 4 * bound_outgoing b + 4 * bound_int_local b + 4 * bound_int_callee_save b) 8.
+Proof.
+  intros. apply align_le. omega.
+Qed.
+
diff --git a/powerpc/macosx/Conventions.v b/powerpc/macosx/Conventions.v
new file mode 100644
index 00000000..4f06b415
--- /dev/null
+++ b/powerpc/macosx/Conventions.v
@@ -0,0 +1,805 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              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.     *)
+(*                                                                     *)
+(* *********************************************************************)
+
+(** Function calling conventions and other conventions regarding the use of 
+    machine registers and stack slots. *)
+
+Require Import Coqlib.
+Require Import AST.
+Require Import Locations.
+
+(** * Classification of machine registers *)
+
+(** Machine registers (type [mreg] in module [Locations]) are divided in
+  the following groups:
+- Temporaries used for spilling, reloading, and parallel move operations.
+- Allocatable registers, that can be assigned to RTL pseudo-registers.
+  These are further divided into:
+-- Callee-save registers, whose value is preserved across a function call.
+-- Caller-save registers that can be modified during a function call.
+
+  We follow the PowerPC/MacOSX application binary interface (ABI) in our choice
+  of callee- and caller-save registers.
+*)
+
+Definition int_caller_save_regs :=
+  R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: nil.
+
+Definition float_caller_save_regs :=
+  F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: F8 :: F9 :: F10 :: nil.
+
+Definition int_callee_save_regs :=
+  R13 :: R14 :: R15 :: R16 :: R17 :: R18 :: R19 :: R20 :: R21 :: R22 :: 
+  R23 :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 :: R30 :: R31 :: nil.
+
+Definition float_callee_save_regs :=
+  F14 :: F15 :: F16 :: F17 :: F18 :: F19 :: F20 :: F21 :: F22 :: 
+  F23 :: F24 :: F25 :: F26 :: F27 :: F28 :: F29 :: F30 :: F31 :: nil.
+
+Definition destroyed_at_call_regs :=
+  int_caller_save_regs ++ float_caller_save_regs.
+
+Definition destroyed_at_call :=
+  List.map R destroyed_at_call_regs.
+
+Definition int_temporaries := IT1 :: IT2 :: nil.
+
+Definition float_temporaries := FT1 :: FT2 :: FT3 :: nil.
+  
+Definition temporaries := 
+  R IT1 :: R IT2 :: R FT1 :: R FT2 :: R FT3 :: nil.
+
+(** The [index_int_callee_save] and [index_float_callee_save] associate
+  a unique positive integer to callee-save registers.  This integer is
+  used in [Stacking] to determine where to save these registers in
+  the activation record if they are used by the current function. *)
+
+Definition index_int_callee_save (r: mreg) :=
+  match r with
+  | R13 => 0  | R14 => 1  | R15 => 2  | R16 => 3
+  | R17 => 4  | R18 => 5  | R19 => 6  | R20 => 7
+  | R21 => 8  | R22 => 9  | R23 => 10 | R24 => 11
+  | R25 => 12 | R26 => 13 | R27 => 14 | R28 => 15
+  | R29 => 16 | R30 => 17 | R31 => 18 | _ => -1
+  end.
+
+Definition index_float_callee_save (r: mreg) :=
+  match r with
+  | F14 => 0  | F15 => 1  | F16 => 2  | F17 => 3
+  | F18 => 4  | F19 => 5  | F20 => 6  | F21 => 7
+  | F22 => 8  | F23 => 9  | F24 => 10 | F25 => 11
+  | F26 => 12 | F27 => 13 | F28 => 14 | F29 => 15
+  | F30 => 16 | F31 => 17 | _ => -1
+  end.
+
+Ltac ElimOrEq :=
+  match goal with
+  |  |- (?x = ?y) \/ _ -> _ =>
+       let H := fresh in
+       (intro H; elim H; clear H;
+        [intro H; rewrite <- H; clear H | ElimOrEq])
+  |  |- False -> _ =>
+       let H := fresh in (intro H; contradiction)
+  end.
+
+Ltac OrEq :=
+  match goal with
+  | |- (?x = ?x) \/ _ => left; reflexivity
+  | |- (?x = ?y) \/ _ => right; OrEq
+  | |- False => fail
+  end.
+
+Ltac NotOrEq :=
+  match goal with
+  | |- (?x = ?y) \/ _ -> False =>
+       let H := fresh in (
+       intro H; elim H; clear H; [intro; discriminate | NotOrEq])
+  | |- False -> False =>
+       contradiction
+  end.
+
+Lemma index_int_callee_save_pos:
+  forall r, In r int_callee_save_regs -> index_int_callee_save r >= 0.
+Proof.
+  intro r. simpl; ElimOrEq; unfold index_int_callee_save; omega.
+Qed.
+
+Lemma index_float_callee_save_pos:
+  forall r, In r float_callee_save_regs -> index_float_callee_save r >= 0.
+Proof.
+  intro r. simpl; ElimOrEq; unfold index_float_callee_save; omega.
+Qed.
+
+Lemma index_int_callee_save_pos2:
+  forall r, index_int_callee_save r >= 0 -> In r int_callee_save_regs.
+Proof.
+  destruct r; simpl; intro; omegaContradiction || OrEq.
+Qed.
+
+Lemma index_float_callee_save_pos2:
+  forall r, index_float_callee_save r >= 0 -> In r float_callee_save_regs.
+Proof.
+  destruct r; simpl; intro; omegaContradiction || OrEq.
+Qed.
+
+Lemma index_int_callee_save_inj:
+  forall r1 r2, 
+  In r1 int_callee_save_regs ->
+  In r2 int_callee_save_regs ->
+  r1 <> r2 ->
+  index_int_callee_save r1 <> index_int_callee_save r2.
+Proof.
+  intros r1 r2. 
+  simpl; ElimOrEq; ElimOrEq; unfold index_int_callee_save;
+  intros; congruence.
+Qed.
+
+Lemma index_float_callee_save_inj:
+  forall r1 r2, 
+  In r1 float_callee_save_regs ->
+  In r2 float_callee_save_regs ->
+  r1 <> r2 ->
+  index_float_callee_save r1 <> index_float_callee_save r2.
+Proof.
+  intros r1 r2. 
+  simpl; ElimOrEq; ElimOrEq; unfold index_float_callee_save;
+  intros; congruence.
+Qed.
+
+(** The following lemmas show that
+    (temporaries, destroyed at call, integer callee-save, float callee-save)
+    is a partition of the set of machine registers. *)
+
+Lemma int_float_callee_save_disjoint:
+  list_disjoint int_callee_save_regs float_callee_save_regs.
+Proof.
+  red; intros r1 r2. simpl; ElimOrEq; ElimOrEq; discriminate.
+Qed.
+
+Lemma register_classification:
+  forall r, 
+  (In (R r) temporaries \/ In (R r) destroyed_at_call) \/
+  (In r int_callee_save_regs \/ In r float_callee_save_regs).
+Proof.
+  destruct r; 
+  try (left; left; simpl; OrEq);
+  try (left; right; simpl; OrEq);
+  try (right; left; simpl; OrEq);
+  try (right; right; simpl; OrEq).
+Qed.
+
+Lemma int_callee_save_not_destroyed:
+  forall r, 
+    In (R r) temporaries \/ In (R r) destroyed_at_call ->
+    ~(In r int_callee_save_regs).
+Proof.
+  intros; red; intros. elim H.
+  generalize H0. simpl; ElimOrEq; NotOrEq.
+  generalize H0. simpl; ElimOrEq; NotOrEq.
+Qed.
+
+Lemma float_callee_save_not_destroyed:
+  forall r, 
+    In (R r) temporaries \/ In (R r) destroyed_at_call ->
+    ~(In r float_callee_save_regs).
+Proof.
+  intros; red; intros. elim H.
+  generalize H0. simpl; ElimOrEq; NotOrEq.
+  generalize H0. simpl; ElimOrEq; NotOrEq.
+Qed.
+
+Lemma int_callee_save_type:
+  forall r, In r int_callee_save_regs -> mreg_type r = Tint.
+Proof.
+  intro. simpl; ElimOrEq; reflexivity.
+Qed.
+
+Lemma float_callee_save_type:
+  forall r, In r float_callee_save_regs -> mreg_type r = Tfloat.
+Proof.
+  intro. simpl; ElimOrEq; reflexivity.
+Qed.
+
+Ltac NoRepet :=
+  match goal with
+  | |- list_norepet nil =>
+      apply list_norepet_nil
+  | |- list_norepet (?a :: ?b) =>
+      apply list_norepet_cons; [simpl; intuition discriminate | NoRepet]
+  end.
+
+Lemma int_callee_save_norepet:
+  list_norepet int_callee_save_regs.
+Proof.
+  unfold int_callee_save_regs; NoRepet.
+Qed.
+
+Lemma float_callee_save_norepet:
+  list_norepet float_callee_save_regs.
+Proof.
+  unfold float_callee_save_regs; NoRepet.
+Qed.
+
+(** * Acceptable locations for register allocation *)
+
+(** The following predicate describes the locations that can be assigned
+  to an RTL pseudo-register during register allocation: a non-temporary
+  machine register or a [Local] stack slot are acceptable. *)
+
+Definition loc_acceptable (l: loc) : Prop :=
+  match l with
+  | R r => ~(In l temporaries)
+  | S (Local ofs ty) => ofs >= 0
+  | S (Incoming _ _) => False
+  | S (Outgoing _ _) => False
+  end.
+
+Definition locs_acceptable (ll: list loc) : Prop :=
+  forall l, In l ll -> loc_acceptable l.
+
+Lemma temporaries_not_acceptable:
+  forall l, loc_acceptable l -> Loc.notin l temporaries.
+Proof.
+  unfold loc_acceptable; destruct l.
+  simpl. intuition congruence.
+  destruct s; try contradiction. 
+  intro. simpl. tauto.
+Qed.
+Hint Resolve temporaries_not_acceptable: locs.
+
+Lemma locs_acceptable_disj_temporaries:
+  forall ll, locs_acceptable ll -> Loc.disjoint ll temporaries.
+Proof.
+  intros. apply Loc.notin_disjoint. intros.
+  apply temporaries_not_acceptable. auto. 
+Qed.
+
+Lemma loc_acceptable_noteq_diff:
+  forall l1 l2,
+  loc_acceptable l1 -> l1 <> l2 -> Loc.diff l1 l2.
+Proof.
+  unfold loc_acceptable, Loc.diff; destruct l1; destruct l2;
+  try (destruct s); try (destruct s0); intros; auto; try congruence.
+  case (zeq z z0); intro. 
+  compare t t0; intro.
+  subst z0; subst t0; tauto.
+  tauto. tauto.
+  contradiction. contradiction.
+Qed.
+
+Lemma loc_acceptable_notin_notin:
+  forall r ll,
+  loc_acceptable r ->
+  ~(In r ll) -> Loc.notin r ll.
+Proof.
+  induction ll; simpl; intros.
+  auto.
+  split. apply loc_acceptable_noteq_diff. assumption. 
+  apply sym_not_equal. tauto. 
+  apply IHll. assumption. tauto. 
+Qed.
+
+(** * Function calling conventions *)
+
+(** The functions in this section determine the locations (machine registers
+  and stack slots) used to communicate arguments and results between the
+  caller and the callee during function calls.  These locations are functions
+  of the signature of the function and of the call instruction.  
+  Agreement between the caller and the callee on the locations to use
+  is guaranteed by our dynamic semantics for Cminor and RTL, which demand 
+  that the signature of the call instruction is identical to that of the
+  called function.
+
+  Calling conventions are largely arbitrary: they must respect the properties
+  proved in this section (such as no overlapping between the locations
+  of function arguments), but this leaves much liberty in choosing actual
+  locations.  To ensure binary interoperability of code generated by our
+  compiler with libraries compiled by another PowerPC compiler, we
+  implement the standard conventions defined in the PowerPC/MacOS X
+  application binary interface. *)
+
+(** ** Location of function result *)
+
+(** The result value of a function is passed back to the caller in
+  registers [R3] or [F1], depending on the type of the returned value.
+  We treat a function without result as a function with one integer result. *)
+
+Definition loc_result (s: signature) : mreg :=
+  match s.(sig_res) with
+  | None => R3
+  | Some Tint => R3
+  | Some Tfloat => F1
+  end.
+
+(** The result location has the type stated in the signature. *)
+
+Lemma loc_result_type:
+  forall sig,
+  mreg_type (loc_result sig) =
+  match sig.(sig_res) with None => Tint | Some ty => ty end.
+Proof.
+  intros; unfold loc_result.
+  destruct (sig_res sig). 
+  destruct t; reflexivity.
+  reflexivity.
+Qed.
+
+(** The result location is acceptable. *)
+
+Lemma loc_result_acceptable:
+  forall sig, loc_acceptable (R (loc_result sig)).
+Proof.
+  intros. unfold loc_acceptable. red.
+  unfold loc_result. destruct (sig_res sig).
+  destruct t; simpl; NotOrEq.
+  simpl; NotOrEq.
+Qed.
+
+(** The result location is a caller-save register. *)
+
+Lemma loc_result_caller_save:
+  forall (s: signature), In (R (loc_result s)) destroyed_at_call.
+Proof.
+  intros; unfold loc_result.
+  destruct (sig_res s). 
+  destruct t; simpl; OrEq.
+  simpl; OrEq.
+Qed.
+
+(** The result location is not a callee-save register. *)
+
+Lemma loc_result_not_callee_save:
+  forall (s: signature),
+  ~(In (loc_result s) int_callee_save_regs \/ In (loc_result s) float_callee_save_regs).
+Proof.
+  intros. generalize (loc_result_caller_save s).
+  generalize (int_callee_save_not_destroyed (loc_result s)).
+  generalize (float_callee_save_not_destroyed (loc_result s)).
+  tauto.
+Qed.
+
+(** ** Location of function arguments *)
+
+(** The PowerPC ABI states the following convention for passing arguments
+  to a function:
+- The first 8 integer arguments are passed in registers [R3] to [R10].
+- The first 10 float arguments are passed in registers [F1] to [F10].
+- Each float argument passed in a float register ``consumes'' two
+  integer arguments.
+- Extra arguments are passed on the stack, in [Outgoing] slots, consecutively
+  assigned (1 word for an integer argument, 2 words for a float),
+  starting at word offset 0.
+- Stack space is reserved (as unused [Outgoing] slots) for the arguments
+  that are passed in registers.
+
+These conventions are somewhat baroque, but they are mandated by the ABI.
+*)
+
+Fixpoint loc_arguments_rec
+    (tyl: list typ) (iregl: list mreg) (fregl: list mreg)
+    (ofs: Z) {struct tyl} : list loc :=
+  match tyl with
+  | nil => nil
+  | Tint :: tys =>
+      match iregl with
+      | nil =>
+          S (Outgoing ofs Tint) :: loc_arguments_rec tys nil fregl (ofs + 1)
+      | ireg :: iregs =>
+          R ireg :: loc_arguments_rec tys iregs fregl ofs
+      end
+  | Tfloat :: tys =>
+      match fregl with
+      | nil =>
+          S (Outgoing ofs Tfloat) :: loc_arguments_rec tys iregl nil (ofs + 2)
+      | freg :: fregs =>
+          R freg :: loc_arguments_rec tys (list_drop2 iregl) fregs ofs
+      end
+  end.
+
+Definition int_param_regs :=
+  R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: nil.
+Definition float_param_regs :=
+  F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: F8 :: F9 :: F10 :: nil.
+
+(** [loc_arguments s] returns the list of locations where to store arguments
+  when calling a function with signature [s].  *)
+
+Definition loc_arguments (s: signature) : list loc :=
+  loc_arguments_rec s.(sig_args) int_param_regs float_param_regs 8.
+
+(** [size_arguments s] returns the number of [Outgoing] slots used
+  to call a function with signature [s]. *)
+
+Fixpoint size_arguments_rec
+    (tyl: list typ) (iregl: list mreg) (fregl: list mreg)
+    (ofs: Z) {struct tyl} : Z :=
+  match tyl with
+  | nil => ofs
+  | Tint :: tys =>
+      match iregl with
+      | nil => size_arguments_rec tys nil fregl (ofs + 1)
+      | ireg :: iregs => size_arguments_rec tys iregs fregl ofs
+      end
+  | Tfloat :: tys =>
+      match fregl with
+      | nil => size_arguments_rec tys iregl nil (ofs + 2)
+      | freg :: fregs => size_arguments_rec tys (list_drop2 iregl) fregs ofs
+      end
+  end.
+
+Definition size_arguments (s: signature) : Z :=
+  size_arguments_rec s.(sig_args) int_param_regs float_param_regs 8.
+
+(** A tail-call is possible for a signature if the corresponding
+    arguments are all passed in registers. *)
+
+Definition tailcall_possible (s: signature) : Prop :=
+  forall l, In l (loc_arguments s) ->
+  match l with R _ => True | S _ => False end.
+
+(** Argument locations are either non-temporary registers or [Outgoing] 
+  stack slots at nonnegative offsets. *)
+
+Definition loc_argument_acceptable (l: loc) : Prop :=
+  match l with
+  | R r => ~(In l temporaries)
+  | S (Outgoing ofs ty) => ofs >= 0
+  | _ => False
+  end.
+
+Remark loc_arguments_rec_charact:
+  forall tyl iregl fregl ofs l,
+  In l (loc_arguments_rec tyl iregl fregl ofs) ->
+  match l with
+  | R r => In r iregl \/ In r fregl
+  | S (Outgoing ofs' ty) => ofs' >= ofs
+  | S _ => False
+  end.
+Proof.
+  induction tyl; simpl loc_arguments_rec; intros.
+  elim H.
+  destruct a. 
+  destruct iregl; elim H; intro. 
+  subst l. omega.
+  generalize (IHtyl _ _ _ _ H0). destruct l; auto. destruct s; auto. omega.
+  subst l. auto with coqlib.
+  generalize (IHtyl _ _ _ _ H0). destruct l; auto. simpl; intuition.
+  destruct fregl; elim H; intro. 
+  subst l. omega.
+  generalize (IHtyl _ _ _ _ H0). destruct l; auto. destruct s; auto. omega.
+  subst l. auto with coqlib.
+  generalize (IHtyl _ _ _ _ H0). destruct l; auto.
+  intros [A|B]. left; apply list_drop2_incl; auto. right; auto with coqlib.
+Qed.
+
+Lemma loc_arguments_acceptable:
+  forall (s: signature) (r: loc),
+  In r (loc_arguments s) -> loc_argument_acceptable r.
+Proof.
+  unfold loc_arguments; intros.
+  generalize (loc_arguments_rec_charact _ _ _ _ _ H).
+  destruct r.
+  intro H0; elim H0. simpl. unfold not. ElimOrEq; NotOrEq.
+  simpl. unfold not. ElimOrEq; NotOrEq.
+  destruct s0; try contradiction.
+  simpl. omega. 
+Qed. 
+Hint Resolve loc_arguments_acceptable: locs.
+
+(** Arguments are parwise disjoint (in the sense of [Loc.norepet]). *)
+
+Remark loc_arguments_rec_notin_reg:
+  forall tyl iregl fregl ofs r,
+  ~(In r iregl) -> ~(In r fregl) ->
+  Loc.notin (R r) (loc_arguments_rec tyl iregl fregl ofs).
+Proof.
+  induction tyl; simpl; intros.
+  auto.
+  destruct a. 
+  destruct iregl; simpl. auto.
+  simpl in H. split. apply sym_not_equal. tauto.
+  apply IHtyl. tauto. tauto.
+  destruct fregl; simpl. auto.
+  simpl in H0. split. apply sym_not_equal. tauto.
+  apply IHtyl. 
+  red; intro. apply H. apply list_drop2_incl. auto.
+  tauto.
+Qed.
+
+Remark loc_arguments_rec_notin_local:
+  forall tyl iregl fregl ofs ofs0 ty0,
+  Loc.notin (S (Local ofs0 ty0)) (loc_arguments_rec tyl iregl fregl ofs).
+Proof.
+  induction tyl; simpl; intros.
+  auto.
+  destruct a.
+  destruct iregl; simpl; auto.
+  destruct fregl; simpl; auto.
+Qed.
+
+Remark loc_arguments_rec_notin_outgoing:
+  forall tyl iregl fregl ofs ofs0 ty0,
+  ofs0 + typesize ty0 <= ofs ->
+  Loc.notin (S (Outgoing ofs0 ty0)) (loc_arguments_rec tyl iregl fregl ofs).
+Proof.
+  induction tyl; simpl; intros.
+  auto.
+  destruct a.
+  destruct iregl; simpl. 
+  split. omega. eapply IHtyl. omega.
+  auto.
+  destruct fregl; simpl. 
+  split. omega. eapply IHtyl. omega.
+  auto.
+Qed.
+
+Lemma loc_arguments_norepet:
+  forall (s: signature), Loc.norepet (loc_arguments s).
+Proof.
+  assert (forall tyl iregl fregl ofs,
+    list_norepet iregl ->
+    list_norepet fregl ->
+    list_disjoint iregl fregl ->
+    Loc.norepet (loc_arguments_rec tyl iregl fregl ofs)).
+  induction tyl; simpl; intros.
+  constructor.
+  destruct a. 
+  destruct iregl; constructor.
+  apply loc_arguments_rec_notin_outgoing. simpl; omega. auto.
+  apply loc_arguments_rec_notin_reg. inversion H. auto.
+  apply list_disjoint_notin with (m :: iregl); auto with coqlib.
+  apply IHtyl. inv H; auto. auto.
+  eapply list_disjoint_cons_left; eauto.
+  destruct fregl; constructor.
+  apply loc_arguments_rec_notin_outgoing. simpl; omega. auto.
+  apply loc_arguments_rec_notin_reg.
+  red; intro. apply (H1 m m). apply list_drop2_incl; auto. 
+  auto with coqlib. auto. inv H0; auto.
+  apply IHtyl. apply list_drop2_norepet; auto.
+  inv H0; auto. 
+  red; intros. apply H1. apply list_drop2_incl; auto. auto with coqlib.
+
+  intro. unfold loc_arguments. apply H.
+  unfold int_param_regs. NoRepet.
+  unfold float_param_regs. NoRepet.
+  red; intros x y; simpl. ElimOrEq; ElimOrEq; discriminate.
+Qed.
+
+(** The offsets of [Outgoing] arguments are below [size_arguments s]. *)
+
+Remark size_arguments_rec_above:
+  forall tyl iregl fregl ofs0,
+  ofs0 <= size_arguments_rec tyl iregl fregl ofs0.
+Proof.
+  induction tyl; simpl; intros.
+  omega.
+  destruct a.
+  destruct iregl. apply Zle_trans with (ofs0 + 1); auto; omega. auto.
+  destruct fregl. apply Zle_trans with (ofs0 + 2); auto; omega. auto.
+Qed.
+
+Lemma size_arguments_above:
+  forall s, size_arguments s >= 0.
+Proof.
+  intros; unfold size_arguments. apply Zle_ge. apply Zle_trans with 8. omega. 
+  apply size_arguments_rec_above.
+Qed.
+
+Lemma loc_arguments_bounded:
+  forall (s: signature) (ofs: Z) (ty: typ),
+  In (S (Outgoing ofs ty)) (loc_arguments s) ->
+  ofs + typesize ty <= size_arguments s.
+Proof.
+  intros.
+  assert (forall tyl iregl fregl ofs0,
+    In (S (Outgoing ofs ty)) (loc_arguments_rec tyl iregl fregl ofs0) ->
+    ofs + typesize ty <= size_arguments_rec tyl iregl fregl ofs0).
+  induction tyl; simpl; intros.
+  elim H0.
+  destruct a. destruct iregl; elim H0; intro.
+  inv H1. simpl. apply size_arguments_rec_above. auto.
+  discriminate. auto. 
+  destruct fregl; elim H0; intro.
+  inv H1. simpl. apply size_arguments_rec_above. auto.
+  discriminate. auto. 
+  unfold size_arguments. eapply H0. unfold loc_arguments in H. eauto.
+Qed.
+
+(** Temporary registers do not overlap with argument locations. *)
+
+Lemma loc_arguments_not_temporaries:
+  forall sig, Loc.disjoint (loc_arguments sig) temporaries.
+Proof.
+  intros; red; intros x1 x2 H.
+  generalize (loc_arguments_rec_charact _ _ _ _ _ H).
+  destruct x1. 
+  intro H0; elim H0; simpl; (ElimOrEq; ElimOrEq; congruence).
+  destruct s; try contradiction. intro.
+  simpl; ElimOrEq; auto.
+Qed.
+Hint Resolve loc_arguments_not_temporaries: locs.
+
+(** Argument registers are caller-save. *)
+
+Lemma arguments_caller_save:
+  forall sig r,
+  In (R r) (loc_arguments sig) -> In (R r) destroyed_at_call.
+Proof.
+  unfold loc_arguments; intros.
+  elim (loc_arguments_rec_charact _ _ _ _ _ H); simpl.
+  ElimOrEq; intuition.
+  ElimOrEq; intuition.
+Qed.
+
+(** Callee-save registers do not overlap with argument locations. *)
+
+Lemma arguments_not_preserved:
+  forall sig l,
+  Loc.notin l destroyed_at_call -> loc_acceptable l ->
+  Loc.notin l (loc_arguments sig).
+Proof.
+  intros. unfold loc_arguments. destruct l.
+  apply loc_arguments_rec_notin_reg. 
+  generalize (Loc.notin_not_in _ _ H). intro; red; intro.
+  apply H1. generalize H2. simpl. ElimOrEq; OrEq. 
+  generalize (Loc.notin_not_in _ _ H). intro; red; intro.
+  apply H1. generalize H2. simpl. ElimOrEq; OrEq. 
+  destruct s; simpl in H0; try contradiction.
+  apply loc_arguments_rec_notin_local.
+Qed.
+Hint Resolve arguments_not_preserved: locs.
+
+(** Argument locations agree in number with the function signature. *)
+
+Lemma loc_arguments_length:
+  forall sig,
+  List.length (loc_arguments sig) = List.length sig.(sig_args).
+Proof.
+  assert (forall tyl iregl fregl ofs,
+    List.length (loc_arguments_rec tyl iregl fregl ofs) = List.length tyl).
+  induction tyl; simpl; intros.
+  auto.
+  destruct a. 
+  destruct iregl; simpl; decEq; auto.
+  destruct fregl; simpl; decEq; auto.
+  intros. unfold loc_arguments. auto.
+Qed.
+
+(** Argument locations agree in types with the function signature. *)
+
+Lemma loc_arguments_type:
+  forall sig, List.map Loc.type (loc_arguments sig) = sig.(sig_args).
+Proof.
+  assert (forall tyl iregl fregl ofs,
+    (forall r, In r iregl -> mreg_type r = Tint) ->
+    (forall r, In r fregl -> mreg_type r = Tfloat) ->
+    List.map Loc.type (loc_arguments_rec tyl iregl fregl ofs) = tyl).
+  induction tyl; simpl; intros.
+  auto.
+  destruct a; [destruct iregl|destruct fregl]; simpl;
+  f_equal; eauto with coqlib.
+  apply IHtyl. intros. apply H. apply list_drop2_incl; auto.
+  eauto with coqlib.
+
+  intros. unfold loc_arguments. apply H. 
+  intro; simpl. ElimOrEq; reflexivity.
+  intro; simpl. ElimOrEq; reflexivity.
+Qed.
+
+(** There is no partial overlap between an argument location and an
+  acceptable location: they are either identical or disjoint. *)
+
+Lemma no_overlap_arguments:
+  forall args sg,
+  locs_acceptable args ->
+  Loc.no_overlap args (loc_arguments sg).
+Proof.
+  unfold Loc.no_overlap; intros.
+  generalize (H r H0).
+  generalize (loc_arguments_acceptable _ _ H1).
+  destruct s; destruct r; simpl.
+  intros. case (mreg_eq m0 m); intro. left; congruence. tauto.
+  intros. right; destruct s; auto.
+  intros. right. auto.
+  destruct s; try tauto. destruct s0; tauto.
+Qed.
+
+(** Decide whether a tailcall is possible. *)
+
+Definition tailcall_is_possible (sg: signature) : bool :=
+  let fix tcisp (l: list loc) :=
+    match l with
+    | nil => true
+    | R _ :: l' => tcisp l'
+    | S _ :: l' => false
+    end
+  in tcisp (loc_arguments sg).
+
+Lemma tailcall_is_possible_correct:
+  forall s, tailcall_is_possible s = true -> tailcall_possible s.
+Proof.
+  intro s. unfold tailcall_is_possible, tailcall_possible.
+  generalize (loc_arguments s). induction l; simpl; intros.
+  elim H0.
+  destruct a. 
+  destruct H0. subst l0. auto. apply IHl. auto. auto. discriminate.
+Qed.
+
+(** ** Location of function parameters *)
+
+(** A function finds the values of its parameter in the same locations
+  where its caller stored them, except that the stack-allocated arguments,
+  viewed as [Outgoing] slots by the caller, are accessed via [Incoming]
+  slots (at the same offsets and types) in the callee. *)
+
+Definition parameter_of_argument (l: loc) : loc :=
+  match l with
+  | S (Outgoing n ty) => S (Incoming n ty)
+  | _ => l
+  end.
+
+Definition loc_parameters (s: signature) :=
+  List.map parameter_of_argument (loc_arguments s).
+
+Lemma loc_parameters_type:
+  forall sig, List.map Loc.type (loc_parameters sig) = sig.(sig_args).
+Proof.
+  intros. unfold loc_parameters.
+  rewrite list_map_compose. 
+  rewrite <- loc_arguments_type.
+  apply list_map_exten.
+  intros. destruct x; simpl. auto. 
+  destruct s; reflexivity.
+Qed.
+
+Lemma loc_parameters_length:
+  forall sg, List.length (loc_parameters sg) = List.length sg.(sig_args).
+Proof.
+  intros. unfold loc_parameters. rewrite list_length_map. 
+  apply loc_arguments_length.
+Qed.
+
+Lemma loc_parameters_not_temporaries:
+  forall sig, Loc.disjoint (loc_parameters sig) temporaries.
+Proof.
+  intro; red; intros.
+  unfold loc_parameters in H. 
+  elim (list_in_map_inv _ _ _ H). intros y [EQ IN].
+  generalize (loc_arguments_not_temporaries sig y x2 IN H0).
+  subst x1. destruct x2.
+  destruct y; simpl. auto. destruct s; auto.
+  byContradiction. generalize H0. simpl. NotOrEq.
+Qed.
+
+Lemma no_overlap_parameters:
+  forall params sg,
+  locs_acceptable params ->
+  Loc.no_overlap (loc_parameters sg) params.
+Proof.
+  unfold Loc.no_overlap; intros.
+  unfold loc_parameters in H0. 
+  elim (list_in_map_inv _ _ _ H0). intros t [EQ IN].
+  rewrite EQ. 
+  generalize (loc_arguments_acceptable _ _ IN).
+  generalize (H s H1).
+  destruct s; destruct t; simpl.
+  intros. case (mreg_eq m0 m); intro. left; congruence. tauto.
+  intros. right; destruct s; simpl; auto.
+  intros; right; auto.
+  destruct s; try tauto. destruct s0; try tauto. 
+  intros; simpl. tauto.
+Qed.
+
+(** ** Location of argument and result for dynamic memory allocation *)
+
+Definition loc_alloc_argument := R3.
+Definition loc_alloc_result := R3.
diff --git a/powerpc/macosx/Stacklayout.v b/powerpc/macosx/Stacklayout.v
new file mode 100644
index 00000000..0e9be224
--- /dev/null
+++ b/powerpc/macosx/Stacklayout.v
@@ -0,0 +1,79 @@
+(* *********************************************************************)
+(*                                                                     *)
+(*              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.     *)
+(*                                                                     *)
+(* *********************************************************************)
+
+(** Machine- and ABI-dependent layout information for activation records. *)
+
+Require Import Coqlib.
+Require Import Bounds.
+
+(** The general shape of activation records is as follows,
+  from bottom (lowest offsets) to top:
+- 24 reserved bytes.  The first 4 bytes hold the back pointer to the
+  activation record of the caller.  We use the 4 bytes at offset 12
+  to store the return address.  (These are reserved by the PowerPC
+  application binary interface.)  The remaining bytes are unused.
+- Space for outgoing arguments to function calls.
+- Local stack slots of integer type.
+- Saved values of integer callee-save registers used by the function.
+- One word of padding, if necessary to align the following data
+  on a 8-byte boundary.
+- Local stack slots of float type.
+- Saved values of float callee-save registers used by the function.
+- Space for the stack-allocated data declared in Cminor.
+
+To facilitate some of the proofs, the Cminor stack-allocated data
+starts at offset 0; the preceding areas in the activation record
+therefore have negative offsets.  This part (with negative offsets)
+is called the ``frame'', by opposition with the ``Cminor stack data''
+which is the part with positive offsets.
+
+The [frame_env] compilation environment records the positions of
+the boundaries between areas in the frame part.
+*)
+
+Definition fe_ofs_arg := 24.
+
+Record frame_env : Set := mk_frame_env {
+  fe_size: Z;
+  fe_ofs_link: Z;
+  fe_ofs_retaddr: Z;
+  fe_ofs_int_local: Z;
+  fe_ofs_int_callee_save: Z;
+  fe_num_int_callee_save: Z;
+  fe_ofs_float_local: Z;
+  fe_ofs_float_callee_save: Z;
+  fe_num_float_callee_save: Z
+}.
+
+(** Computation of the frame environment from the bounds of the current
+  function. *)
+
+Definition make_env (b: bounds) :=
+  let oil := 24 + 4 * b.(bound_outgoing) in    (* integer locals *)
+  let oics := oil + 4 * b.(bound_int_local) in (* integer callee-saves *)
+  let oendi := oics + 4 * b.(bound_int_callee_save) in
+  let ofl := align oendi 8 in       (* float locals *)
+  let ofcs := ofl + 8 * b.(bound_float_local) in (* float callee-saves *)
+  let sz := ofcs + 8 * b.(bound_float_callee_save) in (* total frame size *)
+  mk_frame_env sz 0 12
+                  oil oics b.(bound_int_callee_save)
+                  ofl ofcs b.(bound_float_callee_save).
+
+
+Remark align_float_part:
+  forall b,
+  24 + 4 * bound_outgoing b + 4 * bound_int_local b + 4 * bound_int_callee_save b <=
+  align (24 + 4 * bound_outgoing b + 4 * bound_int_local b + 4 * bound_int_callee_save b) 8.
+Proof.
+  intros. apply align_le. omega.
+Qed.
+