aboutsummaryrefslogtreecommitdiffstats
path: root/x86
diff options
context:
space:
mode:
authorXavier Leroy <xavier.leroy@inria.fr>2016-10-27 11:06:09 +0200
committerXavier Leroy <xavier.leroy@inria.fr>2016-10-27 11:06:09 +0200
commit883341719d7d6868f8165541e7e13ac45192a358 (patch)
tree368ad6e0f2d8e4c99c13a68da0e92c7f00408ae5 /x86
parent88c717e497e0e8a2e6df12418833e46c56291724 (diff)
downloadcompcert-kvx-883341719d7d6868f8165541e7e13ac45192a358.tar.gz
compcert-kvx-883341719d7d6868f8165541e7e13ac45192a358.zip
Make Archi.ptr64 always computable, and reorganize files accordingly: ia32 -> x86/x86_32/x86_64
Having Archi.ptr64 as an opaque Parameter that is determined at run-time depending on compcert.ini is problematic for applications such as VST where functions such as Ctypes.sizeof must compute within Coq. This commit introduces two versions of the Archi.v file, one for x86 32 bits (with ptr64 := false), one for x86 64 bits (with ptr64 := true). Unlike previous approaches, no other file is duplicated between these two variants of x86. While we are at it, I renamed "ia32" into "x86" everywhere. "ia32" is Intel speak for the 32-bit architecture. It is not a good name to describe both the 32 and 64 bit architectures. Finally, .depend is no longer under version control and is regenerated when the target architecture changes. That's because the location of Archi.v differs between the ports that have 32/64 bit variants (x86 so far) and the ports that have only one bitsize (ARM and PowerPC so far).
Diffstat (limited to 'x86')
-rw-r--r--x86/Asm.v1204
-rw-r--r--x86/AsmToJSON.ml17
-rw-r--r--x86/AsmToJSON.mli13
-rw-r--r--x86/Asmexpand.ml638
-rw-r--r--x86/Asmgen.v754
-rw-r--r--x86/Asmgenproof.v916
-rw-r--r--x86/Asmgenproof1.v1477
-rw-r--r--x86/CBuiltins.ml94
-rw-r--r--x86/CombineOp.v150
-rw-r--r--x86/CombineOpproof.v179
-rw-r--r--x86/ConstpropOp.vp404
-rw-r--r--x86/ConstpropOpproof.v883
-rw-r--r--x86/Conventions1.v473
-rw-r--r--x86/Machregs.v367
-rw-r--r--x86/Machregsaux.ml33
-rw-r--r--x86/Machregsaux.mli18
-rw-r--r--x86/NeedOp.v254
-rw-r--r--x86/Op.v1452
-rw-r--r--x86/PrintOp.ml169
-rw-r--r--x86/SelectLong.vp347
-rw-r--r--x86/SelectLongproof.v555
-rw-r--r--x86/SelectOp.vp530
-rw-r--r--x86/SelectOpproof.v959
-rw-r--r--x86/Stacklayout.v148
-rw-r--r--x86/TargetPrinter.ml881
-rw-r--r--x86/ValueAOp.v264
-rw-r--r--x86/extractionMachdep.v26
27 files changed, 13205 insertions, 0 deletions
diff --git a/x86/Asm.v b/x86/Asm.v
new file mode 100644
index 00000000..304cb8e4
--- /dev/null
+++ b/x86/Asm.v
@@ -0,0 +1,1204 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris *)
+(* *)
+(* 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 IA32 assembly language *)
+
+Require Import Coqlib Maps.
+Require Import AST Integers Floats Values Memory Events Globalenvs Smallstep.
+Require Import Locations Stacklayout Conventions.
+
+(** * Abstract syntax *)
+
+(** ** Registers. *)
+
+(** Integer registers. *)
+
+Inductive ireg: Type :=
+ | RAX | RBX | RCX | RDX | RSI | RDI | RBP | RSP
+ | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15.
+
+(** Floating-point registers, i.e. SSE2 registers *)
+
+Inductive freg: Type :=
+ | XMM0 | XMM1 | XMM2 | XMM3 | XMM4 | XMM5 | XMM6 | XMM7
+ | XMM8 | XMM9 | XMM10 | XMM11 | XMM12 | XMM13 | XMM14 | XMM15.
+
+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.
+
+(** Bits of the flags register. *)
+
+Inductive crbit: Type :=
+ | ZF | CF | PF | SF | OF.
+
+(** All registers modeled here. *)
+
+Inductive preg: Type :=
+ | PC: preg (**r program counter *)
+ | IR: ireg -> preg (**r integer register *)
+ | FR: freg -> preg (**r XMM register *)
+ | ST0: preg (**r top of FP stack *)
+ | CR: crbit -> preg (**r bit of the flags register *)
+ | RA: preg. (**r pseudo-reg representing return address *)
+
+Coercion IR: ireg >-> preg.
+Coercion FR: freg >-> preg.
+Coercion CR: crbit >-> preg.
+
+(** Conventional names for stack pointer ([SP]) and return address ([RA]) *)
+
+Notation SP := RSP (only parsing).
+
+(** ** Instruction set. *)
+
+Definition label := positive.
+
+(** General form of an addressing mode. *)
+
+Inductive addrmode: Type :=
+ | Addrmode (base: option ireg)
+ (ofs: option (ireg * Z))
+ (const: Z + ident * ptrofs).
+
+(** Testable conditions (for conditional jumps and more). *)
+
+Inductive testcond: Type :=
+ | Cond_e | Cond_ne
+ | Cond_b | Cond_be | Cond_ae | Cond_a
+ | Cond_l | Cond_le | Cond_ge | Cond_g
+ | Cond_p | Cond_np.
+
+(** Instructions. IA32 instructions accept many combinations of
+ registers, memory references and immediate constants as arguments.
+ Here, we list only the combinations that we actually use.
+
+ Naming conventions for types:
+- [b]: 8 bits
+- [w]: 16 bits ("word")
+- [l]: 32 bits ("longword")
+- [q]: 64 bits ("quadword")
+- [d] or [sd]: FP double precision (64 bits)
+- [s] or [ss]: FP single precision (32 bits)
+
+ Naming conventions for operands:
+- [r]: integer register operand
+- [f]: XMM register operand
+- [m]: memory operand
+- [i]: immediate integer operand
+- [s]: immediate symbol operand
+- [l]: immediate label operand
+- [cl]: the [CL] register
+
+ For two-operand instructions, the first suffix describes the result
+ (and first argument), the second suffix describes the second argument.
+*)
+
+Inductive instruction: Type :=
+ (** Moves *)
+ | Pmov_rr (rd: ireg) (r1: ireg) (**r [mov] (integer) *)
+ | Pmovl_ri (rd: ireg) (n: int)
+ | Pmovq_ri (rd: ireg) (n: int64)
+ | Pmov_rs (rd: ireg) (id: ident)
+ | Pmovl_rm (rd: ireg) (a: addrmode)
+ | Pmovq_rm (rd: ireg) (a: addrmode)
+ | Pmovl_mr (a: addrmode) (rs: ireg)
+ | Pmovq_mr (a: addrmode) (rs: ireg)
+ | Pmovsd_ff (rd: freg) (r1: freg) (**r [movsd] (single 64-bit float) *)
+ | Pmovsd_fi (rd: freg) (n: float) (**r (pseudo-instruction) *)
+ | Pmovsd_fm (rd: freg) (a: addrmode)
+ | Pmovsd_mf (a: addrmode) (r1: freg)
+ | Pmovss_fi (rd: freg) (n: float32) (**r [movss] (single 32-bit float) *)
+ | Pmovss_fm (rd: freg) (a: addrmode)
+ | Pmovss_mf (a: addrmode) (r1: freg)
+ | Pfldl_m (a: addrmode) (**r [fld] double precision *)
+ | Pfstpl_m (a: addrmode) (**r [fstp] double precision *)
+ | Pflds_m (a: addrmode) (**r [fld] simple precision *)
+ | Pfstps_m (a: addrmode) (**r [fstp] simple precision *)
+ (** Moves with conversion *)
+ | Pmovb_mr (a: addrmode) (rs: ireg) (**r [mov] (8-bit int) *)
+ | Pmovw_mr (a: addrmode) (rs: ireg) (**r [mov] (16-bit int) *)
+ | Pmovzb_rr (rd: ireg) (rs: ireg) (**r [movzb] (8-bit zero-extension) *)
+ | Pmovzb_rm (rd: ireg) (a: addrmode)
+ | Pmovsb_rr (rd: ireg) (rs: ireg) (**r [movsb] (8-bit sign-extension) *)
+ | Pmovsb_rm (rd: ireg) (a: addrmode)
+ | Pmovzw_rr (rd: ireg) (rs: ireg) (**r [movzw] (16-bit zero-extension) *)
+ | Pmovzw_rm (rd: ireg) (a: addrmode)
+ | Pmovsw_rr (rd: ireg) (rs: ireg) (**r [movsw] (16-bit sign-extension) *)
+ | Pmovsw_rm (rd: ireg) (a: addrmode)
+ | Pmovzl_rr (rd: ireg) (rs: ireg) (**r [movzl] (32-bit zero-extension) *)
+ | Pmovsl_rr (rd: ireg) (rs: ireg) (**r [movsl] (32-bit sign-extension) *)
+ | Pmovls_rr (rd: ireg) (** 64 to 32 bit conversion (pseudo) *)
+ | Pcvtsd2ss_ff (rd: freg) (r1: freg) (**r conversion to single float *)
+ | Pcvtss2sd_ff (rd: freg) (r1: freg) (**r conversion to double float *)
+ | Pcvttsd2si_rf (rd: ireg) (r1: freg) (**r double to signed int *)
+ | Pcvtsi2sd_fr (rd: freg) (r1: ireg) (**r signed int to double *)
+ | Pcvttss2si_rf (rd: ireg) (r1: freg) (**r single to signed int *)
+ | Pcvtsi2ss_fr (rd: freg) (r1: ireg) (**r signed int to single *)
+ | Pcvttsd2sl_rf (rd: ireg) (r1: freg) (**r double to signed long *)
+ | Pcvtsl2sd_fr (rd: freg) (r1: ireg) (**r signed long to double *)
+ | Pcvttss2sl_rf (rd: ireg) (r1: freg) (**r single to signed long *)
+ | Pcvtsl2ss_fr (rd: freg) (r1: ireg) (**r signed long to single *)
+ (** Integer arithmetic *)
+ | Pleal (rd: ireg) (a: addrmode)
+ | Pleaq (rd: ireg) (a: addrmode)
+ | Pnegl (rd: ireg)
+ | Pnegq (rd: ireg)
+ | Paddl_ri (rd: ireg) (n: int)
+ | Paddq_ri (rd: ireg) (n: int64)
+ | Psubl_rr (rd: ireg) (r1: ireg)
+ | Psubq_rr (rd: ireg) (r1: ireg)
+ | Pimull_rr (rd: ireg) (r1: ireg)
+ | Pimulq_rr (rd: ireg) (r1: ireg)
+ | Pimull_ri (rd: ireg) (n: int)
+ | Pimulq_ri (rd: ireg) (n: int64)
+ | Pimull_r (r1: ireg)
+ | Pimulq_r (r1: ireg)
+ | Pmull_r (r1: ireg)
+ | Pmulq_r (r1: ireg)
+ | Pcltd
+ | Pcqto
+ | Pdivl (r1: ireg)
+ | Pdivq (r1: ireg)
+ | Pidivl (r1: ireg)
+ | Pidivq (r1: ireg)
+ | Pandl_rr (rd: ireg) (r1: ireg)
+ | Pandq_rr (rd: ireg) (r1: ireg)
+ | Pandl_ri (rd: ireg) (n: int)
+ | Pandq_ri (rd: ireg) (n: int64)
+ | Porl_rr (rd: ireg) (r1: ireg)
+ | Porq_rr (rd: ireg) (r1: ireg)
+ | Porl_ri (rd: ireg) (n: int)
+ | Porq_ri (rd: ireg) (n: int64)
+ | Pxorl_r (rd: ireg) (**r [xor] with self = set to zero *)
+ | Pxorq_r (rd: ireg)
+ | Pxorl_rr (rd: ireg) (r1: ireg)
+ | Pxorq_rr (rd: ireg) (r1: ireg)
+ | Pxorl_ri (rd: ireg) (n: int)
+ | Pxorq_ri (rd: ireg) (n: int64)
+ | Pnotl (rd: ireg)
+ | Pnotq (rd: ireg)
+ | Psall_rcl (rd: ireg)
+ | Psalq_rcl (rd: ireg)
+ | Psall_ri (rd: ireg) (n: int)
+ | Psalq_ri (rd: ireg) (n: int)
+ | Pshrl_rcl (rd: ireg)
+ | Pshrq_rcl (rd: ireg)
+ | Pshrl_ri (rd: ireg) (n: int)
+ | Pshrq_ri (rd: ireg) (n: int)
+ | Psarl_rcl (rd: ireg)
+ | Psarq_rcl (rd: ireg)
+ | Psarl_ri (rd: ireg) (n: int)
+ | Psarq_ri (rd: ireg) (n: int)
+ | Pshld_ri (rd: ireg) (r1: ireg) (n: int)
+ | Prorl_ri (rd: ireg) (n: int)
+ | Prorq_ri (rd: ireg) (n: int)
+ | Pcmpl_rr (r1 r2: ireg)
+ | Pcmpq_rr (r1 r2: ireg)
+ | Pcmpl_ri (r1: ireg) (n: int)
+ | Pcmpq_ri (r1: ireg) (n: int64)
+ | Ptestl_rr (r1 r2: ireg)
+ | Ptestq_rr (r1 r2: ireg)
+ | Ptestl_ri (r1: ireg) (n: int)
+ | Ptestq_ri (r1: ireg) (n: int64)
+ | Pcmov (c: testcond) (rd: ireg) (r1: ireg)
+ | Psetcc (c: testcond) (rd: ireg)
+ (** Floating-point arithmetic *)
+ | Paddd_ff (rd: freg) (r1: freg)
+ | Psubd_ff (rd: freg) (r1: freg)
+ | Pmuld_ff (rd: freg) (r1: freg)
+ | Pdivd_ff (rd: freg) (r1: freg)
+ | Pnegd (rd: freg)
+ | Pabsd (rd: freg)
+ | Pcomisd_ff (r1 r2: freg)
+ | Pxorpd_f (rd: freg) (**r [xor] with self = set to zero *)
+ | Padds_ff (rd: freg) (r1: freg)
+ | Psubs_ff (rd: freg) (r1: freg)
+ | Pmuls_ff (rd: freg) (r1: freg)
+ | Pdivs_ff (rd: freg) (r1: freg)
+ | Pnegs (rd: freg)
+ | Pabss (rd: freg)
+ | Pcomiss_ff (r1 r2: freg)
+ | Pxorps_f (rd: freg) (**r [xor] with self = set to zero *)
+ (** Branches and calls *)
+ | Pjmp_l (l: label)
+ | Pjmp_s (symb: ident) (sg: signature)
+ | Pjmp_r (r: ireg) (sg: signature)
+ | Pjcc (c: testcond)(l: label)
+ | Pjcc2 (c1 c2: testcond)(l: label) (**r pseudo *)
+ | Pjmptbl (r: ireg) (tbl: list label) (**r pseudo *)
+ | Pcall_s (symb: ident) (sg: signature)
+ | Pcall_r (r: ireg) (sg: signature)
+ | Pret
+ (** Saving and restoring registers *)
+ | Pmov_rm_a (rd: ireg) (a: addrmode) (**r like [Pmov_rm], using [Many64] chunk *)
+ | Pmov_mr_a (a: addrmode) (rs: ireg) (**r like [Pmov_mr], using [Many64] chunk *)
+ | Pmovsd_fm_a (rd: freg) (a: addrmode) (**r like [Pmovsd_fm], using [Many64] chunk *)
+ | Pmovsd_mf_a (a: addrmode) (r1: freg) (**r like [Pmovsd_mf], using [Many64] chunk *)
+ (** Pseudo-instructions *)
+ | Plabel(l: label)
+ | Pallocframe(sz: Z)(ofs_ra ofs_link: ptrofs)
+ | Pfreeframe(sz: Z)(ofs_ra ofs_link: ptrofs)
+ | Pbuiltin(ef: external_function)(args: list (builtin_arg preg))(res: builtin_res preg)
+ (** Instructions not generated by [Asmgen] -- TO CHECK *)
+ | Padcl_ri (rd: ireg) (n: int)
+ | Padcl_rr (rd: ireg) (r2: ireg)
+ | Paddl_mi (a: addrmode) (n: int)
+ | Paddl_rr (rd: ireg) (r2: ireg)
+ | Pbsfl (rd: ireg) (r1: ireg)
+ | Pbsfq (rd: ireg) (r1: ireg)
+ | Pbsrl (rd: ireg) (r1: ireg)
+ | Pbsrq (rd: ireg) (r1: ireg)
+ | Pbswap64 (rd: ireg)
+ | Pbswap32 (rd: ireg)
+ | Pbswap16 (rd: ireg)
+ | Pcfi_adjust (n: int)
+ | Pfmadd132 (rd: freg) (r2: freg) (r3: freg)
+ | Pfmadd213 (rd: freg) (r2: freg) (r3: freg)
+ | Pfmadd231 (rd: freg) (r2: freg) (r3: freg)
+ | Pfmsub132 (rd: freg) (r2: freg) (r3: freg)
+ | Pfmsub213 (rd: freg) (r2: freg) (r3: freg)
+ | Pfmsub231 (rd: freg) (r2: freg) (r3: freg)
+ | Pfnmadd132 (rd: freg) (r2: freg) (r3: freg)
+ | Pfnmadd213 (rd: freg) (r2: freg) (r3: freg)
+ | Pfnmadd231 (rd: freg) (r2: freg) (r3: freg)
+ | Pfnmsub132 (rd: freg) (r2: freg) (r3: freg)
+ | Pfnmsub213 (rd: freg) (r2: freg) (r3: freg)
+ | Pfnmsub231 (rd: freg) (r2: freg) (r3: freg)
+ | Pmaxsd (rd: freg) (r2: freg)
+ | Pminsd (rd: freg) (r2: freg)
+ | Pmovb_rm (rd: ireg) (a: addrmode)
+ | Pmovsq_mr (a: addrmode) (rs: freg)
+ | Pmovsq_rm (rd: freg) (a: addrmode)
+ | Pmovsb
+ | Pmovsw
+ | Pmovw_rm (rd: ireg) (ad: addrmode)
+ | Prep_movsl
+ | Psbbl_rr (rd: ireg) (r2: ireg)
+ | Psqrtsd (rd: freg) (r1: freg)
+ | Psubl_ri (rd: ireg) (n: int)
+ | Psubq_ri (rd: ireg) (n: int64).
+
+Definition code := list instruction.
+Record function : Type := mkfunction { fn_sig: signature; fn_code: code }.
+Definition fundef := AST.fundef function.
+Definition program := AST.program fundef unit.
+
+(** * Operational semantics *)
+
+Lemma preg_eq: forall (x y: preg), {x=y} + {x<>y}.
+Proof. decide equality. apply ireg_eq. apply freg_eq. decide equality. Defined.
+
+Module PregEq.
+ Definition t := preg.
+ Definition eq := preg_eq.
+End PregEq.
+
+Module Pregmap := EMap(PregEq).
+
+Definition regset := Pregmap.t val.
+Definition genv := Genv.t fundef unit.
+
+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).
+
+(** Undefining some registers *)
+
+Fixpoint undef_regs (l: list preg) (rs: regset) : regset :=
+ match l with
+ | nil => rs
+ | r :: l' => undef_regs l' (rs#r <- Vundef)
+ end.
+
+(** Assigning a register pair *)
+
+Definition set_pair (p: rpair preg) (v: val) (rs: regset) : regset :=
+ match p with
+ | One r => rs#r <- v
+ | Twolong rhi rlo => rs#rhi <- (Val.hiword v) #rlo <- (Val.loword v)
+ end.
+
+(** Assigning the result of a builtin *)
+
+Fixpoint set_res (res: builtin_res preg) (v: val) (rs: regset) : regset :=
+ match res with
+ | BR r => rs#r <- v
+ | BR_none => rs
+ | BR_splitlong hi lo => set_res lo (Val.loword v) (set_res hi (Val.hiword v) rs)
+ end.
+
+Section RELSEM.
+
+(** Looking up instructions in a code sequence by position. *)
+
+Fixpoint find_instr (pos: Z) (c: code) {struct c} : option instruction :=
+ match c with
+ | nil => None
+ | i :: il => if zeq pos 0 then Some i else find_instr (pos - 1) il
+ end.
+
+(** Position corresponding to a label *)
+
+Definition is_label (lbl: label) (instr: instruction) : bool :=
+ match instr with
+ | Plabel lbl' => if peq lbl lbl' then true else false
+ | _ => false
+ end.
+
+Lemma is_label_correct:
+ forall lbl instr,
+ if is_label lbl instr then instr = Plabel lbl else instr <> Plabel lbl.
+Proof.
+ intros. destruct instr; simpl; try discriminate.
+ 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.
+
+Variable ge: genv.
+
+(** Evaluating an addressing mode *)
+
+Definition eval_addrmode32 (a: addrmode) (rs: regset) : val :=
+ let '(Addrmode base ofs const) := a in
+ Val.add (match base with
+ | None => Vint Int.zero
+ | Some r => rs r
+ end)
+ (Val.add (match ofs with
+ | None => Vint Int.zero
+ | Some(r, sc) =>
+ if zeq sc 1
+ then rs r
+ else Val.mul (rs r) (Vint (Int.repr sc))
+ end)
+ (match const with
+ | inl ofs => Vint (Int.repr ofs)
+ | inr(id, ofs) => Genv.symbol_address ge id ofs
+ end)).
+
+Definition eval_addrmode64 (a: addrmode) (rs: regset) : val :=
+ let '(Addrmode base ofs const) := a in
+ Val.addl (match base with
+ | None => Vlong Int64.zero
+ | Some r => rs r
+ end)
+ (Val.addl (match ofs with
+ | None => Vlong Int64.zero
+ | Some(r, sc) =>
+ if zeq sc 1
+ then rs r
+ else Val.mull (rs r) (Vlong (Int64.repr sc))
+ end)
+ (match const with
+ | inl ofs => Vlong (Int64.repr ofs)
+ | inr(id, ofs) => Genv.symbol_address ge id ofs
+ end)).
+
+Definition eval_addrmode (a: addrmode) (rs: regset) : val :=
+ if Archi.ptr64 then eval_addrmode64 a rs else eval_addrmode32 a rs.
+
+(** Performing a comparison *)
+
+(** Integer comparison between x and y:
+- ZF = 1 if x = y, 0 if x != y
+- CF = 1 if x <u y, 0 if x >=u y
+- SF = 1 if x - y is negative, 0 if x - y is positive
+- OF = 1 if x - y overflows (signed), 0 if not
+- PF is undefined
+*)
+
+Definition compare_ints (x y: val) (rs: regset) (m: mem): regset :=
+ rs #ZF <- (Val.cmpu (Mem.valid_pointer m) Ceq x y)
+ #CF <- (Val.cmpu (Mem.valid_pointer m) Clt x y)
+ #SF <- (Val.negative (Val.sub x y))
+ #OF <- (Val.sub_overflow x y)
+ #PF <- Vundef.
+
+Definition compare_longs (x y: val) (rs: regset) (m: mem): regset :=
+ rs #ZF <- (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Ceq x y))
+ #CF <- (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Clt x y))
+ #SF <- (Val.negativel (Val.subl x y))
+ #OF <- (Val.subl_overflow x y)
+ #PF <- Vundef.
+
+(** Floating-point comparison between x and y:
+- ZF = 1 if x=y or unordered, 0 if x<>y
+- CF = 1 if x<y or unordered, 0 if x>=y
+- PF = 1 if unordered, 0 if ordered.
+- SF and 0F are undefined
+*)
+
+Definition compare_floats (vx vy: val) (rs: regset) : regset :=
+ match vx, vy with
+ | Vfloat x, Vfloat y =>
+ rs #ZF <- (Val.of_bool (negb (Float.cmp Cne x y)))
+ #CF <- (Val.of_bool (negb (Float.cmp Cge x y)))
+ #PF <- (Val.of_bool (negb (Float.cmp Ceq x y || Float.cmp Clt x y || Float.cmp Cgt x y)))
+ #SF <- Vundef
+ #OF <- Vundef
+ | _, _ =>
+ undef_regs (CR ZF :: CR CF :: CR PF :: CR SF :: CR OF :: nil) rs
+ end.
+
+Definition compare_floats32 (vx vy: val) (rs: regset) : regset :=
+ match vx, vy with
+ | Vsingle x, Vsingle y =>
+ rs #ZF <- (Val.of_bool (negb (Float32.cmp Cne x y)))
+ #CF <- (Val.of_bool (negb (Float32.cmp Cge x y)))
+ #PF <- (Val.of_bool (negb (Float32.cmp Ceq x y || Float32.cmp Clt x y || Float32.cmp Cgt x y)))
+ #SF <- Vundef
+ #OF <- Vundef
+ | _, _ =>
+ undef_regs (CR ZF :: CR CF :: CR PF :: CR SF :: CR OF :: nil) rs
+ end.
+
+(** Testing a condition *)
+
+Definition eval_testcond (c: testcond) (rs: regset) : option bool :=
+ match c with
+ | Cond_e =>
+ match rs ZF with
+ | Vint n => Some (Int.eq n Int.one)
+ | _ => None
+ end
+ | Cond_ne =>
+ match rs ZF with
+ | Vint n => Some (Int.eq n Int.zero)
+ | _ => None
+ end
+ | Cond_b =>
+ match rs CF with
+ | Vint n => Some (Int.eq n Int.one)
+ | _ => None
+ end
+ | Cond_be =>
+ match rs CF, rs ZF with
+ | Vint c, Vint z => Some (Int.eq c Int.one || Int.eq z Int.one)
+ | _, _ => None
+ end
+ | Cond_ae =>
+ match rs CF with
+ | Vint n => Some (Int.eq n Int.zero)
+ | _ => None
+ end
+ | Cond_a =>
+ match rs CF, rs ZF with
+ | Vint c, Vint z => Some (Int.eq c Int.zero && Int.eq z Int.zero)
+ | _, _ => None
+ end
+ | Cond_l =>
+ match rs OF, rs SF with
+ | Vint o, Vint s => Some (Int.eq (Int.xor o s) Int.one)
+ | _, _ => None
+ end
+ | Cond_le =>
+ match rs OF, rs SF, rs ZF with
+ | Vint o, Vint s, Vint z => Some (Int.eq (Int.xor o s) Int.one || Int.eq z Int.one)
+ | _, _, _ => None
+ end
+ | Cond_ge =>
+ match rs OF, rs SF with
+ | Vint o, Vint s => Some (Int.eq (Int.xor o s) Int.zero)
+ | _, _ => None
+ end
+ | Cond_g =>
+ match rs OF, rs SF, rs ZF with
+ | Vint o, Vint s, Vint z => Some (Int.eq (Int.xor o s) Int.zero && Int.eq z Int.zero)
+ | _, _, _ => None
+ end
+ | Cond_p =>
+ match rs PF with
+ | Vint n => Some (Int.eq n Int.one)
+ | _ => None
+ end
+ | Cond_np =>
+ match rs PF with
+ | Vint n => Some (Int.eq n Int.zero)
+ | _ => None
+ end
+ end.
+
+(** The semantics is purely small-step and defined as a function
+ from the current state (a register set + a memory state)
+ to either [Next rs' m'] where [rs'] and [m'] are the updated register
+ set and memory state after execution of the instruction at [rs#PC],
+ or [Stuck] if the processor is stuck. *)
+
+Inductive outcome: Type :=
+ | Next: regset -> mem -> outcome
+ | Stuck: outcome.
+
+(** Manipulations over the [PC] register: continuing with the next
+ instruction ([nextinstr]) or branching to a label ([goto_label]).
+ [nextinstr_nf] is a variant of [nextinstr] that sets condition flags
+ to [Vundef] in addition to incrementing the [PC]. *)
+
+Definition nextinstr (rs: regset) :=
+ rs#PC <- (Val.offset_ptr rs#PC Ptrofs.one).
+
+Definition nextinstr_nf (rs: regset) : regset :=
+ nextinstr (undef_regs (CR ZF :: CR CF :: CR PF :: CR SF :: CR OF :: nil) rs).
+
+Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) :=
+ match label_pos lbl 0 (fn_code f) with
+ | None => Stuck
+ | Some pos =>
+ match rs#PC with
+ | Vptr b ofs => Next (rs#PC <- (Vptr b (Ptrofs.repr pos))) m
+ | _ => Stuck
+ end
+ end.
+
+(** Auxiliaries for memory accesses. *)
+
+Definition exec_load (chunk: memory_chunk) (m: mem)
+ (a: addrmode) (rs: regset) (rd: preg) :=
+ match Mem.loadv chunk m (eval_addrmode a rs) with
+ | Some v => Next (nextinstr_nf (rs#rd <- v)) m
+ | None => Stuck
+ end.
+
+Definition exec_store (chunk: memory_chunk) (m: mem)
+ (a: addrmode) (rs: regset) (r1: preg)
+ (destroyed: list preg) :=
+ match Mem.storev chunk m (eval_addrmode a rs) (rs r1) with
+ | Some m' => Next (nextinstr_nf (undef_regs destroyed rs)) m'
+ | None => Stuck
+ end.
+
+(** Execution of a single instruction [i] in initial state
+ [rs] and [m]. Return updated state. For instructions
+ that correspond to actual IA32 instructions, the cases are
+ straightforward transliterations of the informal descriptions
+ given in the IA32 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 IA32 code
+ we generate cannot use those registers to hold values that must
+ survive the execution of the pseudo-instruction.
+
+ Concerning condition flags, the comparison instructions set them
+ accurately; other instructions (moves, [lea]) preserve them;
+ and all other instruction set those flags to [Vundef], to reflect
+ the fact that the processor updates some or all of those flags,
+ but we do not need to model this precisely.
+*)
+
+Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : outcome :=
+ match i with
+ (** Moves *)
+ | Pmov_rr rd r1 =>
+ Next (nextinstr (rs#rd <- (rs r1))) m
+ | Pmovl_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Vint n))) m
+ | Pmovq_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Vlong n))) m
+ | Pmov_rs rd id =>
+ Next (nextinstr_nf (rs#rd <- (Genv.symbol_address ge id Ptrofs.zero))) m
+ | Pmovl_rm rd a =>
+ exec_load Mint32 m a rs rd
+ | Pmovq_rm rd a =>
+ exec_load Mint64 m a rs rd
+ | Pmovl_mr a r1 =>
+ exec_store Mint32 m a rs r1 nil
+ | Pmovq_mr a r1 =>
+ exec_store Mint64 m a rs r1 nil
+ | Pmovsd_ff rd r1 =>
+ Next (nextinstr (rs#rd <- (rs r1))) m
+ | Pmovsd_fi rd n =>
+ Next (nextinstr (rs#rd <- (Vfloat n))) m
+ | Pmovsd_fm rd a =>
+ exec_load Mfloat64 m a rs rd
+ | Pmovsd_mf a r1 =>
+ exec_store Mfloat64 m a rs r1 nil
+ | Pmovss_fi rd n =>
+ Next (nextinstr (rs#rd <- (Vsingle n))) m
+ | Pmovss_fm rd a =>
+ exec_load Mfloat32 m a rs rd
+ | Pmovss_mf a r1 =>
+ exec_store Mfloat32 m a rs r1 nil
+ | Pfldl_m a =>
+ exec_load Mfloat64 m a rs ST0
+ | Pfstpl_m a =>
+ exec_store Mfloat64 m a rs ST0 (ST0 :: nil)
+ | Pflds_m a =>
+ exec_load Mfloat32 m a rs ST0
+ | Pfstps_m a =>
+ exec_store Mfloat32 m a rs ST0 (ST0 :: nil)
+ (** Moves with conversion *)
+ | Pmovb_mr a r1 =>
+ exec_store Mint8unsigned m a rs r1 nil
+ | Pmovw_mr a r1 =>
+ exec_store Mint16unsigned m a rs r1 nil
+ | Pmovzb_rr rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.zero_ext 8 rs#r1))) m
+ | Pmovzb_rm rd a =>
+ exec_load Mint8unsigned m a rs rd
+ | Pmovsb_rr rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.sign_ext 8 rs#r1))) m
+ | Pmovsb_rm rd a =>
+ exec_load Mint8signed m a rs rd
+ | Pmovzw_rr rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.zero_ext 16 rs#r1))) m
+ | Pmovzw_rm rd a =>
+ exec_load Mint16unsigned m a rs rd
+ | Pmovsw_rr rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.sign_ext 16 rs#r1))) m
+ | Pmovsw_rm rd a =>
+ exec_load Mint16signed m a rs rd
+ | Pmovzl_rr rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.longofintu rs#r1))) m
+ | Pmovsl_rr rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.longofint rs#r1))) m
+ | Pmovls_rr rd =>
+ Next (nextinstr (rs#rd <- (Val.loword rs#rd))) m
+ | Pcvtsd2ss_ff rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.singleoffloat rs#r1))) m
+ | Pcvtss2sd_ff rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.floatofsingle rs#r1))) m
+ | Pcvttsd2si_rf rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.intoffloat rs#r1)))) m
+ | Pcvtsi2sd_fr rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.floatofint rs#r1)))) m
+ | Pcvttss2si_rf rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.intofsingle rs#r1)))) m
+ | Pcvtsi2ss_fr rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.singleofint rs#r1)))) m
+ | Pcvttsd2sl_rf rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.longoffloat rs#r1)))) m
+ | Pcvtsl2sd_fr rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.floatoflong rs#r1)))) m
+ | Pcvttss2sl_rf rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.longofsingle rs#r1)))) m
+ | Pcvtsl2ss_fr rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.singleoflong rs#r1)))) m
+ (** Integer arithmetic *)
+ | Pleal rd a =>
+ Next (nextinstr (rs#rd <- (eval_addrmode32 a rs))) m
+ | Pleaq rd a =>
+ Next (nextinstr (rs#rd <- (eval_addrmode64 a rs))) m
+ | Pnegl rd =>
+ Next (nextinstr_nf (rs#rd <- (Val.neg rs#rd))) m
+ | Pnegq rd =>
+ Next (nextinstr_nf (rs#rd <- (Val.negl rs#rd))) m
+ | Paddl_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Val.add rs#rd (Vint n)))) m
+ | Paddq_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Val.addl rs#rd (Vlong n)))) m
+ | Psubl_rr rd r1 =>
+ Next (nextinstr_nf (rs#rd <- (Val.sub rs#rd rs#r1))) m
+ | Psubq_rr rd r1 =>
+ Next (nextinstr_nf (rs#rd <- (Val.subl rs#rd rs#r1))) m
+ | Pimull_rr rd r1 =>
+ Next (nextinstr_nf (rs#rd <- (Val.mul rs#rd rs#r1))) m
+ | Pimulq_rr rd r1 =>
+ Next (nextinstr_nf (rs#rd <- (Val.mull rs#rd rs#r1))) m
+ | Pimull_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Val.mul rs#rd (Vint n)))) m
+ | Pimulq_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Val.mull rs#rd (Vlong n)))) m
+ | Pimull_r r1 =>
+ Next (nextinstr_nf (rs#RAX <- (Val.mul rs#RAX rs#r1)
+ #RDX <- (Val.mulhs rs#RAX rs#r1))) m
+ | Pimulq_r r1 =>
+ Next (nextinstr_nf (rs#RAX <- (Val.mull rs#RAX rs#r1)
+ #RDX <- (Val.mullhs rs#RAX rs#r1))) m
+ | Pmull_r r1 =>
+ Next (nextinstr_nf (rs#RAX <- (Val.mul rs#RAX rs#r1)
+ #RDX <- (Val.mulhu rs#RAX rs#r1))) m
+ | Pmulq_r r1 =>
+ Next (nextinstr_nf (rs#RAX <- (Val.mull rs#RAX rs#r1)
+ #RDX <- (Val.mullhu rs#RAX rs#r1))) m
+ | Pcltd =>
+ Next (nextinstr_nf (rs#RDX <- (Val.shr rs#RAX (Vint (Int.repr 31))))) m
+ | Pcqto =>
+ Next (nextinstr_nf (rs#RDX <- (Val.shrl rs#RAX (Vint (Int.repr 63))))) m
+ | Pdivl r1 =>
+ match rs#RDX, rs#RAX, rs#r1 with
+ | Vint nh, Vint nl, Vint d =>
+ match Int.divmodu2 nh nl d with
+ | Some(q, r) => Next (nextinstr_nf (rs#RAX <- (Vint q) #RDX <- (Vint r))) m
+ | None => Stuck
+ end
+ | _, _, _ => Stuck
+ end
+ | Pdivq r1 =>
+ match rs#RDX, rs#RAX, rs#r1 with
+ | Vlong nh, Vlong nl, Vlong d =>
+ match Int64.divmodu2 nh nl d with
+ | Some(q, r) => Next (nextinstr_nf (rs#RAX <- (Vlong q) #RDX <- (Vlong r))) m
+ | None => Stuck
+ end
+ | _, _, _ => Stuck
+ end
+ | Pidivl r1 =>
+ match rs#RDX, rs#RAX, rs#r1 with
+ | Vint nh, Vint nl, Vint d =>
+ match Int.divmods2 nh nl d with
+ | Some(q, r) => Next (nextinstr_nf (rs#RAX <- (Vint q) #RDX <- (Vint r))) m
+ | None => Stuck
+ end
+ | _, _, _ => Stuck
+ end
+ | Pidivq r1 =>
+ match rs#RDX, rs#RAX, rs#r1 with
+ | Vlong nh, Vlong nl, Vlong d =>
+ match Int64.divmods2 nh nl d with
+ | Some(q, r) => Next (nextinstr_nf (rs#RAX <- (Vlong q) #RDX <- (Vlong r))) m
+ | None => Stuck
+ end
+ | _, _, _ => Stuck
+ end
+ | Pandl_rr rd r1 =>
+ Next (nextinstr_nf (rs#rd <- (Val.and rs#rd rs#r1))) m
+ | Pandq_rr rd r1 =>
+ Next (nextinstr_nf (rs#rd <- (Val.andl rs#rd rs#r1))) m
+ | Pandl_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Val.and rs#rd (Vint n)))) m
+ | Pandq_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Val.andl rs#rd (Vlong n)))) m
+ | Porl_rr rd r1 =>
+ Next (nextinstr_nf (rs#rd <- (Val.or rs#rd rs#r1))) m
+ | Porq_rr rd r1 =>
+ Next (nextinstr_nf (rs#rd <- (Val.orl rs#rd rs#r1))) m
+ | Porl_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Val.or rs#rd (Vint n)))) m
+ | Porq_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Val.orl rs#rd (Vlong n)))) m
+ | Pxorl_r rd =>
+ Next (nextinstr_nf (rs#rd <- Vzero)) m
+ | Pxorq_r rd =>
+ Next (nextinstr_nf (rs#rd <- (Vlong Int64.zero))) m
+ | Pxorl_rr rd r1 =>
+ Next (nextinstr_nf (rs#rd <- (Val.xor rs#rd rs#r1))) m
+ | Pxorq_rr rd r1 =>
+ Next (nextinstr_nf (rs#rd <- (Val.xorl rs#rd rs#r1))) m
+ | Pxorl_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Val.xor rs#rd (Vint n)))) m
+ | Pxorq_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Val.xorl rs#rd (Vlong n)))) m
+ | Pnotl rd =>
+ Next (nextinstr_nf (rs#rd <- (Val.notint rs#rd))) m
+ | Pnotq rd =>
+ Next (nextinstr_nf (rs#rd <- (Val.notl rs#rd))) m
+ | Psall_rcl rd =>
+ Next (nextinstr_nf (rs#rd <- (Val.shl rs#rd rs#RCX))) m
+ | Psalq_rcl rd =>
+ Next (nextinstr_nf (rs#rd <- (Val.shll rs#rd rs#RCX))) m
+ | Psall_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Val.shl rs#rd (Vint n)))) m
+ | Psalq_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Val.shll rs#rd (Vint n)))) m
+ | Pshrl_rcl rd =>
+ Next (nextinstr_nf (rs#rd <- (Val.shru rs#rd rs#RCX))) m
+ | Pshrq_rcl rd =>
+ Next (nextinstr_nf (rs#rd <- (Val.shrlu rs#rd rs#RCX))) m
+ | Pshrl_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Val.shru rs#rd (Vint n)))) m
+ | Pshrq_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Val.shrlu rs#rd (Vint n)))) m
+ | Psarl_rcl rd =>
+ Next (nextinstr_nf (rs#rd <- (Val.shr rs#rd rs#RCX))) m
+ | Psarq_rcl rd =>
+ Next (nextinstr_nf (rs#rd <- (Val.shrl rs#rd rs#RCX))) m
+ | Psarl_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Val.shr rs#rd (Vint n)))) m
+ | Psarq_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Val.shrl rs#rd (Vint n)))) m
+ | Pshld_ri rd r1 n =>
+ Next (nextinstr_nf
+ (rs#rd <- (Val.or (Val.shl rs#rd (Vint n))
+ (Val.shru rs#r1 (Vint (Int.sub Int.iwordsize n)))))) m
+ | Prorl_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Val.ror rs#rd (Vint n)))) m
+ | Prorq_ri rd n =>
+ Next (nextinstr_nf (rs#rd <- (Val.rorl rs#rd (Vint n)))) m
+ | Pcmpl_rr r1 r2 =>
+ Next (nextinstr (compare_ints (rs r1) (rs r2) rs m)) m
+ | Pcmpq_rr r1 r2 =>
+ Next (nextinstr (compare_longs (rs r1) (rs r2) rs m)) m
+ | Pcmpl_ri r1 n =>
+ Next (nextinstr (compare_ints (rs r1) (Vint n) rs m)) m
+ | Pcmpq_ri r1 n =>
+ Next (nextinstr (compare_longs (rs r1) (Vlong n) rs m)) m
+ | Ptestl_rr r1 r2 =>
+ Next (nextinstr (compare_ints (Val.and (rs r1) (rs r2)) Vzero rs m)) m
+ | Ptestq_rr r1 r2 =>
+ Next (nextinstr (compare_longs (Val.andl (rs r1) (rs r2)) (Vlong Int64.zero) rs m)) m
+ | Ptestl_ri r1 n =>
+ Next (nextinstr (compare_ints (Val.and (rs r1) (Vint n)) Vzero rs m)) m
+ | Ptestq_ri r1 n =>
+ Next (nextinstr (compare_longs (Val.andl (rs r1) (Vlong n)) (Vlong Int64.zero) rs m)) m
+ | Pcmov c rd r1 =>
+ match eval_testcond c rs with
+ | Some true => Next (nextinstr (rs#rd <- (rs#r1))) m
+ | Some false => Next (nextinstr rs) m
+ | None => Next (nextinstr (rs#rd <- Vundef)) m
+ end
+ | Psetcc c rd =>
+ Next (nextinstr (rs#rd <- (Val.of_optbool (eval_testcond c rs)))) m
+ (** Arithmetic operations over double-precision floats *)
+ | Paddd_ff rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.addf rs#rd rs#r1))) m
+ | Psubd_ff rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.subf rs#rd rs#r1))) m
+ | Pmuld_ff rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.mulf rs#rd rs#r1))) m
+ | Pdivd_ff rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.divf rs#rd rs#r1))) m
+ | Pnegd rd =>
+ Next (nextinstr (rs#rd <- (Val.negf rs#rd))) m
+ | Pabsd rd =>
+ Next (nextinstr (rs#rd <- (Val.absf rs#rd))) m
+ | Pcomisd_ff r1 r2 =>
+ Next (nextinstr (compare_floats (rs r1) (rs r2) rs)) m
+ | Pxorpd_f rd =>
+ Next (nextinstr_nf (rs#rd <- (Vfloat Float.zero))) m
+ (** Arithmetic operations over single-precision floats *)
+ | Padds_ff rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.addfs rs#rd rs#r1))) m
+ | Psubs_ff rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.subfs rs#rd rs#r1))) m
+ | Pmuls_ff rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.mulfs rs#rd rs#r1))) m
+ | Pdivs_ff rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.divfs rs#rd rs#r1))) m
+ | Pnegs rd =>
+ Next (nextinstr (rs#rd <- (Val.negfs rs#rd))) m
+ | Pabss rd =>
+ Next (nextinstr (rs#rd <- (Val.absfs rs#rd))) m
+ | Pcomiss_ff r1 r2 =>
+ Next (nextinstr (compare_floats32 (rs r1) (rs r2) rs)) m
+ | Pxorps_f rd =>
+ Next (nextinstr_nf (rs#rd <- (Vsingle Float32.zero))) m
+ (** Branches and calls *)
+ | Pjmp_l lbl =>
+ goto_label f lbl rs m
+ | Pjmp_s id sg =>
+ Next (rs#PC <- (Genv.symbol_address ge id Ptrofs.zero)) m
+ | Pjmp_r r sg =>
+ Next (rs#PC <- (rs r)) m
+ | Pjcc cond lbl =>
+ match eval_testcond cond rs with
+ | Some true => goto_label f lbl rs m
+ | Some false => Next (nextinstr rs) m
+ | None => Stuck
+ end
+ | Pjcc2 cond1 cond2 lbl =>
+ match eval_testcond cond1 rs, eval_testcond cond2 rs with
+ | Some true, Some true => goto_label f lbl rs m
+ | Some _, Some _ => Next (nextinstr rs) m
+ | _, _ => Stuck
+ end
+ | Pjmptbl r tbl =>
+ match rs#r with
+ | Vint n =>
+ match list_nth_z tbl (Int.unsigned n) with
+ | None => Stuck
+ | Some lbl => goto_label f lbl (rs #RAX <- Vundef #RDX <- Vundef) m
+ end
+ | _ => Stuck
+ end
+ | Pcall_s id sg =>
+ Next (rs#RA <- (Val.offset_ptr rs#PC Ptrofs.one) #PC <- (Genv.symbol_address ge id Ptrofs.zero)) m
+ | Pcall_r r sg =>
+ Next (rs#RA <- (Val.offset_ptr rs#PC Ptrofs.one) #PC <- (rs r)) m
+ | Pret =>
+ Next (rs#PC <- (rs#RA)) m
+ (** Saving and restoring registers *)
+ | Pmov_rm_a rd a =>
+ exec_load (if Archi.ptr64 then Many64 else Many32) m a rs rd
+ | Pmov_mr_a a r1 =>
+ exec_store (if Archi.ptr64 then Many64 else Many32) m a rs r1 nil
+ | Pmovsd_fm_a rd a =>
+ exec_load Many64 m a rs rd
+ | Pmovsd_mf_a a r1 =>
+ exec_store Many64 m a rs r1 nil
+ (** Pseudo-instructions *)
+ | Plabel lbl =>
+ Next (nextinstr rs) m
+ | Pallocframe sz ofs_ra ofs_link =>
+ let (m1, stk) := Mem.alloc m 0 sz in
+ let sp := Vptr stk Ptrofs.zero in
+ match Mem.storev Mptr m1 (Val.offset_ptr sp ofs_link) rs#RSP with
+ | None => Stuck
+ | Some m2 =>
+ match Mem.storev Mptr m2 (Val.offset_ptr sp ofs_ra) rs#RA with
+ | None => Stuck
+ | Some m3 => Next (nextinstr (rs #RAX <- (rs#RSP) #RSP <- sp)) m3
+ end
+ end
+ | Pfreeframe sz ofs_ra ofs_link =>
+ match Mem.loadv Mptr m (Val.offset_ptr rs#RSP ofs_ra) with
+ | None => Stuck
+ | Some ra =>
+ match Mem.loadv Mptr m (Val.offset_ptr rs#RSP ofs_link) with
+ | None => Stuck
+ | Some sp =>
+ match rs#RSP with
+ | Vptr stk ofs =>
+ match Mem.free m stk 0 sz with
+ | None => Stuck
+ | Some m' => Next (nextinstr (rs#RSP <- sp #RA <- ra)) m'
+ end
+ | _ => Stuck
+ end
+ end
+ end
+ | Pbuiltin ef args res =>
+ Stuck (**r treated specially below *)
+ (** The following instructions and directives are not generated
+ directly by [Asmgen], so we do not model them. *)
+ | Padcl_ri _ _
+ | Padcl_rr _ _
+ | Paddl_mi _ _
+ | Paddl_rr _ _
+ | Pbsfl _ _
+ | Pbsfq _ _
+ | Pbsrl _ _
+ | Pbsrq _ _
+ | Pbswap64 _
+ | Pbswap32 _
+ | Pbswap16 _
+ | Pcfi_adjust _
+ | Pfmadd132 _ _ _
+ | Pfmadd213 _ _ _
+ | Pfmadd231 _ _ _
+ | Pfmsub132 _ _ _
+ | Pfmsub213 _ _ _
+ | Pfmsub231 _ _ _
+ | Pfnmadd132 _ _ _
+ | Pfnmadd213 _ _ _
+ | Pfnmadd231 _ _ _
+ | Pfnmsub132 _ _ _
+ | Pfnmsub213 _ _ _
+ | Pfnmsub231 _ _ _
+ | Pmaxsd _ _
+ | Pminsd _ _
+ | Pmovb_rm _ _
+ | Pmovsq_rm _ _
+ | Pmovsq_mr _ _
+ | Pmovsb
+ | Pmovsw
+ | Pmovw_rm _ _
+ | Prep_movsl
+ | Psbbl_rr _ _
+ | Psqrtsd _ _
+ | Psubl_ri _ _
+ | Psubq_ri _ _ => Stuck
+ end.
+
+(** Translation of the LTL/Linear/Mach view of machine registers
+ to the Asm view. *)
+
+Definition preg_of (r: mreg) : preg :=
+ match r with
+ | AX => IR RAX
+ | BX => IR RBX
+ | CX => IR RCX
+ | DX => IR RDX
+ | SI => IR RSI
+ | DI => IR RDI
+ | BP => IR RBP
+ | Machregs.R8 => IR R8
+ | Machregs.R9 => IR R9
+ | Machregs.R10 => IR R10
+ | Machregs.R11 => IR R11
+ | Machregs.R12 => IR R12
+ | Machregs.R13 => IR R13
+ | Machregs.R14 => IR R14
+ | Machregs.R15 => IR R15
+ | X0 => FR XMM0
+ | X1 => FR XMM1
+ | X2 => FR XMM2
+ | X3 => FR XMM3
+ | X4 => FR XMM4
+ | X5 => FR XMM5
+ | X6 => FR XMM6
+ | X7 => FR XMM7
+ | X8 => FR XMM8
+ | X9 => FR XMM9
+ | X10 => FR XMM10
+ | X11 => FR XMM11
+ | X12 => FR XMM12
+ | X13 => FR XMM13
+ | X14 => FR XMM14
+ | X15 => FR XMM15
+ | FP0 => ST0
+ end.
+
+(** Extract the values of the arguments of an external call.
+ We exploit the calling conventions from module [Conventions], except that
+ we use machine registers instead of locations. *)
+
+Inductive extcall_arg (rs: regset) (m: mem): loc -> val -> Prop :=
+ | extcall_arg_reg: forall r,
+ extcall_arg rs m (R r) (rs (preg_of r))
+ | extcall_arg_stack: forall ofs ty bofs v,
+ bofs = Stacklayout.fe_ofs_arg + 4 * ofs ->
+ Mem.loadv (chunk_of_type ty) m
+ (Val.offset_ptr (rs (IR RSP)) (Ptrofs.repr bofs)) = Some v ->
+ extcall_arg rs m (S Outgoing ofs ty) v.
+
+Inductive extcall_arg_pair (rs: regset) (m: mem): rpair loc -> val -> Prop :=
+ | extcall_arg_one: forall l v,
+ extcall_arg rs m l v ->
+ extcall_arg_pair rs m (One l) v
+ | extcall_arg_twolong: forall hi lo vhi vlo,
+ extcall_arg rs m hi vhi ->
+ extcall_arg rs m lo vlo ->
+ extcall_arg_pair rs m (Twolong hi lo) (Val.longofwords vhi vlo).
+
+Definition extcall_arguments
+ (rs: regset) (m: mem) (sg: signature) (args: list val) : Prop :=
+ list_forall2 (extcall_arg_pair rs m) (loc_arguments sg) args.
+
+Definition loc_external_result (sg: signature) : rpair preg :=
+ map_rpair preg_of (loc_result sg).
+
+(** Execution of the instruction at [rs#PC]. *)
+
+Inductive state: Type :=
+ | State: regset -> mem -> state.
+
+Inductive step: state -> trace -> state -> Prop :=
+ | exec_step_internal:
+ forall b ofs f i rs m rs' m',
+ rs PC = Vptr b ofs ->
+ Genv.find_funct_ptr ge b = Some (Internal f) ->
+ find_instr (Ptrofs.unsigned ofs) f.(fn_code) = Some i ->
+ exec_instr f i rs m = Next rs' m' ->
+ step (State rs m) E0 (State rs' m')
+ | exec_step_builtin:
+ forall b ofs f ef args res rs m vargs t vres rs' m',
+ rs PC = Vptr b ofs ->
+ Genv.find_funct_ptr ge b = Some (Internal f) ->
+ find_instr (Ptrofs.unsigned ofs) f.(fn_code) = Some (Pbuiltin ef args res) ->
+ eval_builtin_args ge rs (rs RSP) m args vargs ->
+ external_call ef ge vargs m t vres m' ->
+ rs' = nextinstr_nf
+ (set_res res vres
+ (undef_regs (map preg_of (destroyed_by_builtin ef)) rs)) ->
+ step (State rs m) t (State rs' m')
+ | exec_step_external:
+ forall b ef args res rs m t rs' m',
+ rs PC = Vptr b Ptrofs.zero ->
+ Genv.find_funct_ptr ge b = Some (External ef) ->
+ extcall_arguments rs m (ef_sig ef) args ->
+ external_call ef ge args m t res m' ->
+ rs' = (set_pair (loc_external_result (ef_sig ef)) res rs) #PC <- (rs RA) ->
+ step (State rs m) t (State rs' m').
+
+End RELSEM.
+
+(** Execution of whole programs. *)
+
+Inductive initial_state (p: program): state -> Prop :=
+ | initial_state_intro: forall m0,
+ Genv.init_mem p = Some m0 ->
+ let ge := Genv.globalenv p in
+ let rs0 :=
+ (Pregmap.init Vundef)
+ # PC <- (Genv.symbol_address ge p.(prog_main) Ptrofs.zero)
+ # RA <- Vnullptr
+ # RSP <- Vnullptr in
+ initial_state p (State rs0 m0).
+
+Inductive final_state: state -> int -> Prop :=
+ | final_state_intro: forall rs m r,
+ rs#PC = Vnullptr ->
+ rs#RAX = Vint r ->
+ final_state (State rs m) r.
+
+Definition semantics (p: program) :=
+ Semantics step (initial_state p) final_state (Genv.globalenv p).
+
+(** Determinacy of the [Asm] semantics. *)
+
+Remark extcall_arguments_determ:
+ forall rs m sg args1 args2,
+ extcall_arguments rs m sg args1 -> extcall_arguments rs m sg args2 -> args1 = args2.
+Proof.
+ intros until m.
+ assert (A: forall l v1 v2,
+ extcall_arg rs m l v1 -> extcall_arg rs m l v2 -> v1 = v2).
+ { intros. inv H; inv H0; congruence. }
+ assert (B: forall p v1 v2,
+ extcall_arg_pair rs m p v1 -> extcall_arg_pair rs m p v2 -> v1 = v2).
+ { intros. inv H; inv H0.
+ eapply A; eauto.
+ f_equal; eapply A; eauto. }
+ assert (C: forall ll vl1, list_forall2 (extcall_arg_pair rs m) ll vl1 ->
+ forall vl2, list_forall2 (extcall_arg_pair rs m) ll vl2 -> vl1 = vl2).
+ {
+ induction 1; intros vl2 EA; inv EA.
+ auto.
+ f_equal; eauto. }
+ intros. eapply C; eauto.
+Qed.
+
+Lemma semantics_determinate: forall p, determinate (semantics p).
+Proof.
+Ltac Equalities :=
+ match goal with
+ | [ H1: ?a = ?b, H2: ?a = ?c |- _ ] =>
+ rewrite H1 in H2; inv H2; Equalities
+ | _ => idtac
+ end.
+ intros; constructor; simpl; intros.
+- (* determ *)
+ inv H; inv H0; Equalities.
++ split. constructor. auto.
++ discriminate.
++ discriminate.
++ assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0.
+ exploit external_call_determ. eexact H5. eexact H11. intros [A B].
+ split. auto. intros. destruct B; auto. subst. auto.
++ assert (args0 = args) by (eapply extcall_arguments_determ; eauto). subst args0.
+ exploit external_call_determ. eexact H4. eexact H9. intros [A B].
+ split. auto. intros. destruct B; auto. subst. auto.
+- (* trace length *)
+ red; intros; inv H; simpl.
+ omega.
+ eapply external_call_trace_length; eauto.
+ eapply external_call_trace_length; eauto.
+- (* initial states *)
+ inv H; inv H0. f_equal. congruence.
+- (* final no step *)
+ assert (NOTNULL: forall b ofs, Vnullptr <> Vptr b ofs).
+ { intros; unfold Vnullptr; destruct Archi.ptr64; congruence. }
+ inv H. red; intros; red; intros. inv H; rewrite H0 in *; eelim NOTNULL; eauto.
+- (* final states *)
+ inv H; inv H0. congruence.
+Qed.
+
+(** Classification functions for processor registers (used in Asmgenproof). *)
+
+Definition data_preg (r: preg) : bool :=
+ match r with
+ | PC => false
+ | IR _ => true
+ | FR _ => true
+ | ST0 => true
+ | CR _ => false
+ | RA => false
+ end.
+
diff --git a/x86/AsmToJSON.ml b/x86/AsmToJSON.ml
new file mode 100644
index 00000000..3214491f
--- /dev/null
+++ b/x86/AsmToJSON.ml
@@ -0,0 +1,17 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *)
+(* *)
+(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *)
+(* is distributed under the terms of the INRIA Non-Commercial *)
+(* License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Simple functions to serialize ia32 Asm to JSON *)
+
+(* Dummy function *)
+let p_program oc prog =
+ ()
diff --git a/x86/AsmToJSON.mli b/x86/AsmToJSON.mli
new file mode 100644
index 00000000..20bcba5e
--- /dev/null
+++ b/x86/AsmToJSON.mli
@@ -0,0 +1,13 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *)
+(* *)
+(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *)
+(* is distributed under the terms of the INRIA Non-Commercial *)
+(* License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+val p_program: out_channel -> (Asm.coq_function AST.fundef, 'a) AST.program -> unit
diff --git a/x86/Asmexpand.ml b/x86/Asmexpand.ml
new file mode 100644
index 00000000..0436bc86
--- /dev/null
+++ b/x86/Asmexpand.ml
@@ -0,0 +1,638 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *)
+(* *)
+(* 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. *)
+(* *)
+(* *********************************************************************)
+
+(* Expanding built-ins and some pseudo-instructions by rewriting
+ of the IA32 assembly code. *)
+
+open Asm
+open Asmexpandaux
+open AST
+open Camlcoq
+open Datatypes
+
+exception Error of string
+
+(* Useful constants and helper functions *)
+
+let _0 = Integers.Int.zero
+let _1 = Integers.Int.one
+let _2 = coqint_of_camlint 2l
+let _4 = coqint_of_camlint 4l
+let _8 = coqint_of_camlint 8l
+
+let _0z = Z.zero
+let _1z = Z.one
+let _2z = Z.of_sint 2
+let _4z = Z.of_sint 4
+let _8z = Z.of_sint 8
+let _16z = Z.of_sint 16
+
+let stack_alignment () = 16
+
+(* Pseudo instructions for 32/64 bit compatibility *)
+
+let _Plea (r, addr) =
+ if Archi.ptr64 then Pleaq (r, addr) else Pleal (r, addr)
+
+(* SP adjustment to allocate or free a stack frame *)
+
+let align n a =
+ if n >= 0 then (n + a - 1) land (-a) else n land (-a)
+
+let sp_adjustment_32 sz =
+ let sz = Z.to_int sz in
+ (* Preserve proper alignment of the stack *)
+ let sz = align sz (stack_alignment ()) in
+ (* The top 4 bytes have already been allocated by the "call" instruction. *)
+ sz - 4
+
+let sp_adjustment_64 sz =
+ let sz = Z.to_int sz in
+ if is_current_function_variadic() then begin
+ (* If variadic, add room for register save area, which must be 16-aligned *)
+ let ofs = align (sz - 8) 16 in
+ let sz = ofs + 176 (* save area *) + 8 (* return address *) in
+ (* Preserve proper alignment of the stack *)
+ let sz = align sz 16 in
+ (* The top 8 bytes have already been allocated by the "call" instruction. *)
+ (sz - 8, ofs)
+ end else begin
+ (* Preserve proper alignment of the stack *)
+ let sz = align sz 16 in
+ (* The top 8 bytes have already been allocated by the "call" instruction. *)
+ (sz - 8, -1)
+ end
+
+(* Built-ins. They come in two flavors:
+ - annotation statements: take their arguments in registers or stack
+ locations; generate no code;
+ - inlined by the compiler: take their arguments in arbitrary
+ registers; preserve all registers except ECX, EDX, XMM6 and XMM7. *)
+
+(* Handling of annotations *)
+
+let expand_annot_val txt targ args res =
+ emit (Pbuiltin (EF_annot(txt,[targ]), args, BR_none));
+ match args, res with
+ | [BA(IR src)], BR(IR dst) ->
+ if dst <> src then emit (Pmov_rr (dst,src))
+ | [BA(FR src)], BR(FR dst) ->
+ if dst <> src then emit (Pmovsd_ff (dst,src))
+ | _, _ ->
+ raise (Error "ill-formed __builtin_annot_intval")
+
+(* Operations on addressing modes *)
+
+let offset_addressing (Addrmode(base, ofs, cst)) delta =
+ Addrmode(base, ofs,
+ match cst with
+ | Coq_inl n -> Coq_inl(Z.add n delta)
+ | Coq_inr(id, n) -> Coq_inr(id, Integers.Ptrofs.add n delta))
+
+let linear_addr reg ofs = Addrmode(Some reg, None, Coq_inl ofs)
+let global_addr id ofs = Addrmode(None, None, Coq_inr(id, ofs))
+
+(* Translate a builtin argument into an addressing mode *)
+
+let addressing_of_builtin_arg = function
+ | BA (IR r) -> linear_addr r Z.zero
+ | BA_addrstack ofs -> linear_addr RSP (Integers.Ptrofs.unsigned ofs)
+ | BA_addrglobal(id, ofs) -> global_addr id ofs
+ | _ -> assert false
+
+(* Handling of memcpy *)
+
+(* Unaligned memory accesses are quite fast on IA32, so use large
+ memory accesses regardless of alignment. *)
+
+let expand_builtin_memcpy_small sz al src dst =
+ let rec copy src dst sz =
+ if sz >= 8 && Archi.ptr64 then begin
+ emit (Pmovq_rm (RCX, src));
+ emit (Pmovq_mr (dst, RCX));
+ copy (offset_addressing src _8z) (offset_addressing dst _8z) (sz - 8)
+ end else if sz >= 8 && !Clflags.option_ffpu then begin
+ emit (Pmovsq_rm (XMM7, src));
+ emit (Pmovsq_mr (dst, XMM7));
+ copy (offset_addressing src _8z) (offset_addressing dst _8z) (sz - 8)
+ end else if sz >= 4 then begin
+ emit (Pmovl_rm (RCX, src));
+ emit (Pmovl_mr (dst, RCX));
+ copy (offset_addressing src _4z) (offset_addressing dst _4z) (sz - 4)
+ end else if sz >= 2 then begin
+ emit (Pmovw_rm (RCX, src));
+ emit (Pmovw_mr (dst, RCX));
+ copy (offset_addressing src _2z) (offset_addressing dst _2z) (sz - 2)
+ end else if sz >= 1 then begin
+ emit (Pmovb_rm (RCX, src));
+ emit (Pmovb_mr (dst, RCX));
+ copy (offset_addressing src _1z) (offset_addressing dst _1z) (sz - 1)
+ end in
+ copy (addressing_of_builtin_arg src) (addressing_of_builtin_arg dst) sz
+
+let expand_builtin_memcpy_big sz al src dst =
+ if src <> BA (IR RSI) then emit (_Plea (RSI, addressing_of_builtin_arg src));
+ if dst <> BA (IR RDI) then emit (_Plea (RDI, addressing_of_builtin_arg dst));
+ (* TODO: movsq? *)
+ emit (Pmovl_ri (RCX,coqint_of_camlint (Int32.of_int (sz / 4))));
+ emit Prep_movsl;
+ if sz mod 4 >= 2 then emit Pmovsw;
+ if sz mod 2 >= 1 then emit Pmovsb
+
+let expand_builtin_memcpy sz al args =
+ let (dst, src) = match args with [d; s] -> (d, s) | _ -> assert false in
+ if sz <= 32
+ then expand_builtin_memcpy_small sz al src dst
+ else expand_builtin_memcpy_big sz al src dst
+
+(* Handling of volatile reads and writes *)
+
+let expand_builtin_vload_common chunk addr res =
+ match chunk, res with
+ | Mint8unsigned, BR(IR res) ->
+ emit (Pmovzb_rm (res,addr))
+ | Mint8signed, BR(IR res) ->
+ emit (Pmovsb_rm (res,addr))
+ | Mint16unsigned, BR(IR res) ->
+ emit (Pmovzw_rm (res,addr))
+ | Mint16signed, BR(IR res) ->
+ emit (Pmovsw_rm (res,addr))
+ | Mint32, BR(IR res) ->
+ emit (Pmovl_rm (res,addr))
+ | Mint64, BR(IR res) ->
+ emit (Pmovq_rm (res,addr))
+ | Mint64, BR_splitlong(BR(IR res1), BR(IR res2)) ->
+ let addr' = offset_addressing addr _4z in
+ if not (Asmgen.addressing_mentions addr res2) then begin
+ emit (Pmovl_rm (res2,addr));
+ emit (Pmovl_rm (res1,addr'))
+ end else begin
+ emit (Pmovl_rm (res1,addr'));
+ emit (Pmovl_rm (res2,addr))
+ end
+ | Mfloat32, BR(FR res) ->
+ emit (Pmovss_fm (res,addr))
+ | Mfloat64, BR(FR res) ->
+ emit (Pmovsd_fm (res,addr))
+ | _ ->
+ assert false
+
+let expand_builtin_vload chunk args res =
+ match args with
+ | [addr] ->
+ expand_builtin_vload_common chunk (addressing_of_builtin_arg addr) res
+ | _ ->
+ assert false
+
+let expand_builtin_vstore_common chunk addr src tmp =
+ match chunk, src with
+ | (Mint8signed | Mint8unsigned), BA(IR src) ->
+ if Archi.ptr64 || Asmgen.low_ireg src then
+ emit (Pmovb_mr (addr,src))
+ else begin
+ emit (Pmov_rr (tmp,src));
+ emit (Pmovb_mr (addr,tmp))
+ end
+ | (Mint16signed | Mint16unsigned), BA(IR src) ->
+ emit (Pmovw_mr (addr,src))
+ | Mint32, BA(IR src) ->
+ emit (Pmovl_mr (addr,src))
+ | Mint64, BA(IR src) ->
+ emit (Pmovq_mr (addr,src))
+ | Mint64, BA_splitlong(BA(IR src1), BA(IR src2)) ->
+ let addr' = offset_addressing addr _4z in
+ emit (Pmovl_mr (addr,src2));
+ emit (Pmovl_mr (addr',src1))
+ | Mfloat32, BA(FR src) ->
+ emit (Pmovss_mf (addr,src))
+ | Mfloat64, BA(FR src) ->
+ emit (Pmovsd_mf (addr,src))
+ | _ ->
+ assert false
+
+let expand_builtin_vstore chunk args =
+ match args with
+ | [addr; src] ->
+ let addr = addressing_of_builtin_arg addr in
+ expand_builtin_vstore_common chunk addr src
+ (if Asmgen.addressing_mentions addr RAX then RCX else RAX)
+ | _ -> assert false
+
+(* Handling of varargs *)
+
+let rec next_arg_locations ir fr ofs = function
+ | [] ->
+ (ir, fr, ofs)
+ | (Tint | Tlong | Tany32 | Tany64) :: l ->
+ if ir < 6
+ then next_arg_locations (ir + 1) fr ofs l
+ else next_arg_locations ir fr (ofs + 8) l
+ | (Tfloat | Tsingle) :: l ->
+ if fr < 8
+ then next_arg_locations ir (fr + 1) ofs l
+ else next_arg_locations ir fr (ofs + 8) l
+
+let current_function_stacksize = ref 0L
+
+let expand_builtin_va_start_32 r =
+ if not (is_current_function_variadic ()) then
+ invalid_arg "Fatal error: va_start used in non-vararg function";
+ let ofs =
+ Int32.(add (add !PrintAsmaux.current_function_stacksize 4l)
+ (mul 4l (Z.to_int32 (Conventions1.size_arguments
+ (get_current_function_sig ()))))) in
+ emit (Pleal (RAX, linear_addr RSP (Z.of_uint32 ofs)));
+ emit (Pmovl_mr (linear_addr r _0z, RAX))
+
+let expand_builtin_va_start_64 r =
+ if not (is_current_function_variadic ()) then
+ invalid_arg "Fatal error: va_start used in non-vararg function";
+ let (ir, fr, ofs) =
+ next_arg_locations 0 0 0 (get_current_function_args ()) in
+ (* [r] points to the following struct:
+ struct {
+ unsigned int gp_offset;
+ unsigned int fp_offset;
+ void *overflow_arg_area;
+ void *reg_save_area;
+ }
+ gp_offset is initialized to ir * 8
+ fp_offset is initialized to 6 * 8 + fr * 16
+ overflow_arg_area is initialized to sp + current stacksize + ofs
+ reg_save_area is initialized to
+ sp + current stacksize - 16 - save area size (6 * 8 + 8 * 16) *)
+ let gp_offset = Int32.of_int (ir * 8)
+ and fp_offset = Int32.of_int (6 * 8 + fr * 16)
+ and overflow_arg_area = Int64.(add !current_function_stacksize (of_int ofs))
+ and reg_save_area = Int64.(sub !current_function_stacksize 192L) in
+ assert (r <> RAX);
+ emit (Pmovl_ri (RAX, coqint_of_camlint gp_offset));
+ emit (Pmovl_mr (linear_addr r _0z, RAX));
+ emit (Pmovl_ri (RAX, coqint_of_camlint fp_offset));
+ emit (Pmovl_mr (linear_addr r _4z, RAX));
+ emit (Pleaq (RAX, linear_addr RSP (Z.of_uint64 overflow_arg_area)));
+ emit (Pmovq_mr (linear_addr r _8z, RAX));
+ emit (Pleaq (RAX, linear_addr RSP (Z.of_uint64 reg_save_area)));
+ emit (Pmovq_mr (linear_addr r _16z, RAX))
+
+(* FMA operations *)
+
+(* vfmadd<i><j><k> r1, r2, r3 performs r1 := ri * rj + rk
+ hence
+ vfmadd132 r1, r2, r3 performs r1 := r1 * r3 + r2
+ vfmadd213 r1, r2, r3 performs r1 := r2 * r1 + r3
+ vfmadd231 r1, r2, r3 performs r1 := r2 * r3 + r1
+*)
+
+let expand_fma args res i132 i213 i231 =
+ match args, res with
+ | [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) ->
+ if res = a1 then emit (i132 a1 a3 a2) (* a1 * a2 + a3 *)
+ else if res = a2 then emit (i213 a2 a1 a3) (* a1 * a2 + a3 *)
+ else if res = a3 then emit (i231 a3 a1 a2) (* a1 * a2 + a3 *)
+ else begin
+ emit (Pmovsd_ff(res, a3));
+ emit (i231 res a1 a2) (* a1 * a2 + res *)
+ end
+ | _ ->
+ invalid_arg ("ill-formed fma builtin")
+
+(* Handling of compiler-inlined builtins *)
+
+let expand_builtin_inline name args res =
+ match name, args, res with
+ (* Integer arithmetic *)
+ | ("__builtin_bswap"| "__builtin_bswap32"), [BA(IR a1)], BR(IR res) ->
+ if a1 <> res then
+ emit (Pmov_rr (res,a1));
+ emit (Pbswap32 res)
+ | "__builtin_bswap64", [BA(IR a1)], BR(IR res) ->
+ if a1 <> res then
+ emit (Pmov_rr (res,a1));
+ emit (Pbswap64 res)
+ | "__builtin_bswap64", [BA_splitlong(BA(IR ah), BA(IR al))],
+ BR_splitlong(BR(IR rh), BR(IR rl)) ->
+ assert (ah = RAX && al = RDX && rh = RDX && rl = RAX);
+ emit (Pbswap32 RAX);
+ emit (Pbswap32 RDX)
+ | "__builtin_bswap16", [BA(IR a1)], BR(IR res) ->
+ if a1 <> res then
+ emit (Pmov_rr (res,a1));
+ emit (Pbswap16 res)
+ | ("__builtin_clz"|"__builtin_clzl"), [BA(IR a1)], BR(IR res) ->
+ emit (Pbsrl (res,a1));
+ emit (Pxorl_ri(res,coqint_of_camlint 31l))
+ | "__builtin_clzll", [BA(IR a1)], BR(IR res) ->
+ emit (Pbsrq (res,a1));
+ emit (Pxorl_ri(res,coqint_of_camlint 63l))
+ | "__builtin_clzll", [BA_splitlong(BA (IR ah), BA (IR al))], BR(IR res) ->
+ let lbl1 = new_label() in
+ let lbl2 = new_label() in
+ emit (Ptestl_rr(ah, ah));
+ emit (Pjcc(Cond_e, lbl1));
+ emit (Pbsrl(res, ah));
+ emit (Pxorl_ri(res, coqint_of_camlint 31l));
+ emit (Pjmp_l lbl2);
+ emit (Plabel lbl1);
+ emit (Pbsrl(res, al));
+ emit (Pxorl_ri(res, coqint_of_camlint 63l));
+ emit (Plabel lbl2)
+ | ("__builtin_ctz" | "__builtin_ctzl"), [BA(IR a1)], BR(IR res) ->
+ emit (Pbsfl (res,a1))
+ | "__builtin_ctzll", [BA(IR a1)], BR(IR res) ->
+ emit (Pbsfq (res,a1))
+ | "__builtin_ctzll", [BA_splitlong(BA (IR ah), BA (IR al))], BR(IR res) ->
+ let lbl1 = new_label() in
+ let lbl2 = new_label() in
+ emit (Ptestl_rr(al, al));
+ emit (Pjcc(Cond_e, lbl1));
+ emit (Pbsfl(res, al));
+ emit (Pjmp_l lbl2);
+ emit (Plabel lbl1);
+ emit (Pbsfl(res, ah));
+ emit (Paddl_ri(res, coqint_of_camlint 32l));
+ emit (Plabel lbl2)
+ (* Float arithmetic *)
+ | "__builtin_fabs", [BA(FR a1)], BR(FR res) ->
+ if a1 <> res then
+ emit (Pmovsd_ff (res,a1));
+ emit (Pabsd res) (* This ensures that need_masks is set to true *)
+ | "__builtin_fsqrt", [BA(FR a1)], BR(FR res) ->
+ emit (Psqrtsd (res,a1))
+ | "__builtin_fmax", [BA(FR a1); BA(FR a2)], BR(FR res) ->
+ if res = a1 then
+ emit (Pmaxsd (res,a2))
+ else if res = a2 then
+ emit (Pmaxsd (res,a1))
+ else begin
+ emit (Pmovsd_ff (res,a1));
+ emit (Pmaxsd (res,a2))
+ end
+ | "__builtin_fmin", [BA(FR a1); BA(FR a2)], BR(FR res) ->
+ if res = a1 then
+ emit (Pminsd (res,a2))
+ else if res = a2 then
+ emit (Pminsd (res,a1))
+ else begin
+ emit (Pmovsd_ff (res,a1));
+ emit (Pminsd (res,a2))
+ end
+ | "__builtin_fmadd", _, _ ->
+ expand_fma args res
+ (fun r1 r2 r3 -> Pfmadd132(r1, r2, r3))
+ (fun r1 r2 r3 -> Pfmadd213(r1, r2, r3))
+ (fun r1 r2 r3 -> Pfmadd231(r1, r2, r3))
+ | "__builtin_fmsub", _, _ ->
+ expand_fma args res
+ (fun r1 r2 r3 -> Pfmsub132(r1, r2, r3))
+ (fun r1 r2 r3 -> Pfmsub213(r1, r2, r3))
+ (fun r1 r2 r3 -> Pfmsub231(r1, r2, r3))
+ | "__builtin_fnmadd", _, _ ->
+ expand_fma args res
+ (fun r1 r2 r3 -> Pfnmadd132(r1, r2, r3))
+ (fun r1 r2 r3 -> Pfnmadd213(r1, r2, r3))
+ (fun r1 r2 r3 -> Pfnmadd231(r1, r2, r3))
+ | "__builtin_fnmsub", _, _ ->
+ expand_fma args res
+ (fun r1 r2 r3 -> Pfnmsub132(r1, r2, r3))
+ (fun r1 r2 r3 -> Pfnmsub213(r1, r2, r3))
+ (fun r1 r2 r3 -> Pfnmsub231(r1, r2, r3))
+ (* 64-bit integer arithmetic *)
+ | "__builtin_negl", [BA_splitlong(BA(IR ah), BA(IR al))],
+ BR_splitlong(BR(IR rh), BR(IR rl)) ->
+ assert (ah = RDX && al = RAX && rh = RDX && rl = RAX);
+ emit (Pnegl RAX);
+ emit (Padcl_ri (RDX,_0));
+ emit (Pnegl RDX)
+ | "__builtin_addl", [BA_splitlong(BA(IR ah), BA(IR al));
+ BA_splitlong(BA(IR bh), BA(IR bl))],
+ BR_splitlong(BR(IR rh), BR(IR rl)) ->
+ assert (ah = RDX && al = RAX && bh = RCX && bl = RBX && rh = RDX && rl = RAX);
+ emit (Paddl_rr (RAX,RBX));
+ emit (Padcl_rr (RDX,RCX))
+ | "__builtin_subl", [BA_splitlong(BA(IR ah), BA(IR al));
+ BA_splitlong(BA(IR bh), BA(IR bl))],
+ BR_splitlong(BR(IR rh), BR(IR rl)) ->
+ assert (ah = RDX && al = RAX && bh = RCX && bl = RBX && rh = RDX && rl = RAX);
+ emit (Psubl_rr (RAX,RBX));
+ emit (Psbbl_rr (RDX,RCX))
+ | "__builtin_mull", [BA(IR a); BA(IR b)],
+ BR_splitlong(BR(IR rh), BR(IR rl)) ->
+ assert (a = RAX && b = RDX && rh = RDX && rl = RAX);
+ emit (Pmull_r RDX)
+ (* Memory accesses *)
+ | "__builtin_read16_reversed", [BA(IR a1)], BR(IR res) ->
+ emit (Pmovzw_rm (res, linear_addr a1 _0));
+ emit (Pbswap16 res)
+ | "__builtin_read32_reversed", [BA(IR a1)], BR(IR res) ->
+ emit (Pmovl_rm (res, linear_addr a1 _0));
+ emit (Pbswap32 res)
+ | "__builtin_write16_reversed", [BA(IR a1); BA(IR a2)], _ ->
+ let tmp = if a1 = RCX then RDX else RCX in
+ if a2 <> tmp then
+ emit (Pmov_rr (tmp,a2));
+ emit (Pbswap16 tmp);
+ emit (Pmovw_mr (linear_addr a1 _0z, tmp))
+ | "__builtin_write32_reversed", [BA(IR a1); BA(IR a2)], _ ->
+ let tmp = if a1 = RCX then RDX else RCX in
+ if a2 <> tmp then
+ emit (Pmov_rr (tmp,a2));
+ emit (Pbswap32 tmp);
+ emit (Pmovl_mr (linear_addr a1 _0z, tmp))
+ (* Vararg stuff *)
+ | "__builtin_va_start", [BA(IR a)], _ ->
+ assert (a = RDX);
+ if Archi.ptr64
+ then expand_builtin_va_start_64 a
+ else expand_builtin_va_start_32 a
+ (* Synchronization *)
+ | "__builtin_membar", [], _ ->
+ ()
+ (* no operation *)
+ | "__builtin_nop", [], _ ->
+ emit (Pmov_rr (RAX,RAX))
+ (* Catch-all *)
+ | _ ->
+ raise (Error ("unrecognized builtin " ^ name))
+
+(* Calls to variadic functions for x86-64: register AL must contain
+ the number of XMM registers used for parameter passing. To be on
+ the safe side. do the same if the called function is
+ unprototyped. *)
+
+let set_al sg =
+ if Archi.ptr64 && (sg.sig_cc.cc_vararg || sg.sig_cc.cc_unproto) then begin
+ let (ir, fr, ofs) = next_arg_locations 0 0 0 sg.sig_args in
+ emit (Pmovl_ri (RAX, coqint_of_camlint (Int32.of_int fr)))
+ end
+
+(* Expansion of instructions *)
+
+let expand_instruction instr =
+ match instr with
+ | Pallocframe (sz, ofs_ra, ofs_link) ->
+ if Archi.ptr64 then begin
+ let (sz, save_regs) = sp_adjustment_64 sz in
+ (* Allocate frame *)
+ let sz' = Z.of_uint sz in
+ emit (Psubq_ri (RSP, sz'));
+ emit (Pcfi_adjust sz');
+ if save_regs >= 0 then begin
+ (* Save the registers *)
+ emit (Pleaq (R10, linear_addr RSP (Z.of_uint save_regs)));
+ emit (Pcall_s (intern_string "__compcert_va_saveregs",
+ {sig_args = []; sig_res = None; sig_cc = cc_default}))
+ end;
+ (* Stack chaining *)
+ let fullsz = sz + 8 in
+ let addr1 = linear_addr RSP (Z.of_uint fullsz) in
+ let addr2 = linear_addr RSP ofs_link in
+ emit (Pleaq (RAX, addr1));
+ emit (Pmovq_mr (addr2, RAX));
+ current_function_stacksize := Int64.of_int fullsz
+ end else begin
+ let sz = sp_adjustment_32 sz in
+ (* Allocate frame *)
+ let sz' = Z.of_uint sz in
+ emit (Psubl_ri (RSP, sz'));
+ emit (Pcfi_adjust sz');
+ (* Stack chaining *)
+ let addr1 = linear_addr RSP (Z.of_uint (sz + 4)) in
+ let addr2 = linear_addr RSP ofs_link in
+ emit (Pleal (RAX,addr1));
+ emit (Pmovl_mr (addr2,RAX));
+ PrintAsmaux.current_function_stacksize := Int32.of_int sz
+ end
+ | Pfreeframe(sz, ofs_ra, ofs_link) ->
+ if Archi.ptr64 then begin
+ let (sz, _) = sp_adjustment_64 sz in
+ emit (Paddq_ri (RSP, Z.of_uint sz))
+ end else begin
+ let sz = sp_adjustment_32 sz in
+ emit (Paddl_ri (RSP, Z.of_uint sz))
+ end
+ | Pjmp_s(_, sg) | Pjmp_r(_, sg) | Pcall_s(_, sg) | Pcall_r(_, sg) ->
+ set_al sg;
+ emit instr
+ | Pbuiltin (ef,args, res) ->
+ begin
+ match ef with
+ | EF_builtin(name, sg) ->
+ expand_builtin_inline (camlstring_of_coqstring name) args res
+ | EF_vload chunk ->
+ expand_builtin_vload chunk args res
+ | EF_vstore chunk ->
+ expand_builtin_vstore chunk args
+ | EF_memcpy(sz, al) ->
+ expand_builtin_memcpy (Z.to_int sz) (Z.to_int al) args
+ | EF_annot_val(txt, targ) ->
+ expand_annot_val txt targ args res
+ | EF_annot _ | EF_debug _ | EF_inline_asm _ ->
+ emit instr
+ | _ ->
+ assert false
+ end
+ | _ -> emit instr
+
+let int_reg_to_dwarf_32 = function
+ | RAX -> 0
+ | RBX -> 3
+ | RCX -> 1
+ | RDX -> 2
+ | RSI -> 6
+ | RDI -> 7
+ | RBP -> 5
+ | RSP -> 4
+ | _ -> assert false
+
+let int_reg_to_dwarf_64 = function
+ | RAX -> 0
+ | RDX -> 1
+ | RCX -> 2
+ | RBX -> 3
+ | RSI -> 4
+ | RDI -> 5
+ | RBP -> 6
+ | RSP -> 7
+ | R8 -> 8
+ | R9 -> 9
+ | R10 -> 10
+ | R11 -> 11
+ | R12 -> 12
+ | R13 -> 13
+ | R14 -> 14
+ | R15 -> 15
+
+let int_reg_to_dwarf =
+ if Archi.ptr64 then int_reg_to_dwarf_64 else int_reg_to_dwarf_32
+
+let float_reg_to_dwarf_32 = function
+ | XMM0 -> 21
+ | XMM1 -> 22
+ | XMM2 -> 23
+ | XMM3 -> 24
+ | XMM4 -> 25
+ | XMM5 -> 26
+ | XMM6 -> 27
+ | XMM7 -> 28
+ | _ -> assert false
+
+let float_reg_to_dwarf_64 = function
+ | XMM0 -> 17
+ | XMM1 -> 18
+ | XMM2 -> 19
+ | XMM3 -> 20
+ | XMM4 -> 21
+ | XMM5 -> 22
+ | XMM6 -> 23
+ | XMM7 -> 24
+ | XMM8 -> 25
+ | XMM9 -> 26
+ | XMM10 -> 27
+ | XMM11 -> 28
+ | XMM12 -> 29
+ | XMM13 -> 30
+ | XMM14 -> 31
+ | XMM15 -> 32
+
+let float_reg_to_dwarf =
+ if Archi.ptr64 then float_reg_to_dwarf_64 else float_reg_to_dwarf_32
+
+let preg_to_dwarf = function
+ | IR r -> int_reg_to_dwarf r
+ | FR r -> float_reg_to_dwarf r
+ | _ -> assert false
+
+
+let expand_function id fn =
+ try
+ set_current_function fn;
+ if !Clflags.option_g then
+ expand_debug id 4 preg_to_dwarf expand_instruction fn.fn_code
+ else
+ List.iter expand_instruction fn.fn_code;
+ Errors.OK (get_current_function ())
+ with Error s ->
+ Errors.Error (Errors.msg (coqstring_of_camlstring s))
+
+let expand_fundef id = function
+ | Internal f ->
+ begin match expand_function id f with
+ | Errors.OK tf -> Errors.OK (Internal tf)
+ | Errors.Error msg -> Errors.Error msg
+ end
+ | External ef ->
+ Errors.OK (External ef)
+
+let expand_program (p: Asm.program) : Asm.program Errors.res =
+ AST.transform_partial_program2 expand_fundef (fun id v -> Errors.OK v) p
diff --git a/x86/Asmgen.v b/x86/Asmgen.v
new file mode 100644
index 00000000..bb26d507
--- /dev/null
+++ b/x86/Asmgen.v
@@ -0,0 +1,754 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris *)
+(* *)
+(* 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 IA32 assembly language *)
+
+Require Import Coqlib Errors.
+Require Import AST Integers Floats Memdata.
+Require Import Op Locations Mach Asm.
+
+Open Local Scope string_scope.
+Open Local Scope error_monad_scope.
+
+(** The code generation functions take advantage of several characteristics of the [Mach] code generated by earlier passes of the compiler:
+- Argument and result registers are of the correct type.
+- For two-address instructions, the result and the first argument
+ are in the same register. (True by construction in [RTLgen], and preserved by [Reload].)
+- The top of the floating-point stack ([ST0], a.k.a. [FP0]) can only
+ appear in [mov] instructions, but never in arithmetic instructions.
+
+All these properties are true by construction, but it is painful to track them statically. Instead, we recheck them during code generation and fail if they do not hold.
+*)
+
+(** Extracting integer or float registers. *)
+
+Definition ireg_of (r: mreg) : res ireg :=
+ match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgen.ireg_of") end.
+
+Definition freg_of (r: mreg) : res freg :=
+ match preg_of r with FR mr => OK mr | _ => Error(msg "Asmgen.freg_of") end.
+
+(** Smart constructors for some operations. *)
+
+Definition mk_mov (rd rs: preg) (k: code) : res code :=
+ match rd, rs with
+ | IR rd, IR rs => OK (Pmov_rr rd rs :: k)
+ | FR rd, FR rs => OK (Pmovsd_ff rd rs :: k)
+ | _, _ => Error(msg "Asmgen.mk_mov")
+ end.
+
+Definition mk_shrximm (n: int) (k: code) : res code :=
+ let p := Int.sub (Int.shl Int.one n) Int.one in
+ OK (Ptestl_rr RAX RAX ::
+ Pleal RCX (Addrmode (Some RAX) None (inl _ (Int.unsigned p))) ::
+ Pcmov Cond_l RAX RCX ::
+ Psarl_ri RAX n :: k).
+
+Definition mk_shrxlimm (n: int) (k: code) : res code :=
+ OK (if Int.eq n Int.zero then Pmov_rr RAX RAX :: k else
+ Pcqto ::
+ Pshrq_ri RDX (Int.sub (Int.repr 64) n) ::
+ Pleaq RAX (Addrmode (Some RAX) (Some(RDX, 1)) (inl _ 0)) ::
+ Psarq_ri RAX n :: k).
+
+Definition low_ireg (r: ireg) : bool :=
+ match r with RAX | RBX | RCX | RDX => true | _ => false end.
+
+Definition mk_intconv (mk: ireg -> ireg -> instruction) (rd rs: ireg) (k: code) :=
+ if Archi.ptr64 || low_ireg rs then
+ OK (mk rd rs :: k)
+ else
+ OK (Pmov_rr RAX rs :: mk rd RAX :: k).
+
+Definition addressing_mentions (addr: addrmode) (r: ireg) : bool :=
+ match addr with Addrmode base displ const =>
+ match base with Some r' => ireg_eq r r' | None => false end
+ || match displ with Some(r', sc) => ireg_eq r r' | None => false end
+ end.
+
+Definition mk_storebyte (addr: addrmode) (rs: ireg) (k: code) :=
+ if Archi.ptr64 || low_ireg rs then
+ OK (Pmovb_mr addr rs :: k)
+ else if addressing_mentions addr RAX then
+ OK (Pleal RCX addr :: Pmov_rr RAX rs ::
+ Pmovb_mr (Addrmode (Some RCX) None (inl _ 0)) RAX :: k)
+ else
+ OK (Pmov_rr RAX rs :: Pmovb_mr addr RAX :: k).
+
+(** Accessing slots in the stack frame. *)
+
+Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: code) :=
+ let a := Addrmode (Some base) None (inl _ (Ptrofs.unsigned ofs)) in
+ match ty, preg_of dst with
+ | Tint, IR r => OK (Pmovl_rm r a :: k)
+ | Tlong, IR r => OK (Pmovq_rm r a :: k)
+ | Tsingle, FR r => OK (Pmovss_fm r a :: k)
+ | Tsingle, ST0 => OK (Pflds_m a :: k)
+ | Tfloat, FR r => OK (Pmovsd_fm r a :: k)
+ | Tfloat, ST0 => OK (Pfldl_m a :: k)
+ | Tany32, IR r => if Archi.ptr64 then Error (msg "Asmgen.loadind1") else OK (Pmov_rm_a r a :: k)
+ | Tany64, IR r => if Archi.ptr64 then OK (Pmov_rm_a r a :: k) else Error (msg "Asmgen.loadind2")
+ | Tany64, FR r => OK (Pmovsd_fm_a r a :: k)
+ | _, _ => Error (msg "Asmgen.loadind")
+ end.
+
+Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: code) :=
+ let a := Addrmode (Some base) None (inl _ (Ptrofs.unsigned ofs)) in
+ match ty, preg_of src with
+ | Tint, IR r => OK (Pmovl_mr a r :: k)
+ | Tlong, IR r => OK (Pmovq_mr a r :: k)
+ | Tsingle, FR r => OK (Pmovss_mf a r :: k)
+ | Tsingle, ST0 => OK (Pfstps_m a :: k)
+ | Tfloat, FR r => OK (Pmovsd_mf a r :: k)
+ | Tfloat, ST0 => OK (Pfstpl_m a :: k)
+ | Tany32, IR r => if Archi.ptr64 then Error (msg "Asmgen.storeind1") else OK (Pmov_mr_a a r :: k)
+ | Tany64, IR r => if Archi.ptr64 then OK (Pmov_mr_a a r :: k) else Error (msg "Asmgen.storeind2")
+ | Tany64, FR r => OK (Pmovsd_mf_a a r :: k)
+ | _, _ => Error (msg "Asmgen.storeind")
+ end.
+
+(** Translation of addressing modes *)
+
+Definition transl_addressing (a: addressing) (args: list mreg): res addrmode :=
+ match a, args with
+ | Aindexed n, a1 :: nil =>
+ do r1 <- ireg_of a1; OK(Addrmode (Some r1) None (inl _ n))
+ | Aindexed2 n, a1 :: a2 :: nil =>
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK(Addrmode (Some r1) (Some(r2, 1)) (inl _ n))
+ | Ascaled sc n, a1 :: nil =>
+ do r1 <- ireg_of a1; OK(Addrmode None (Some(r1, sc)) (inl _ n))
+ | Aindexed2scaled sc n, a1 :: a2 :: nil =>
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK(Addrmode (Some r1) (Some(r2, sc)) (inl _ n))
+ | Aglobal id ofs, nil =>
+ OK(Addrmode None None (inr _ (id, ofs)))
+ | Abased id ofs, a1 :: nil =>
+ do r1 <- ireg_of a1; OK(Addrmode (Some r1) None (inr _ (id, ofs)))
+ | Abasedscaled sc id ofs, a1 :: nil =>
+ do r1 <- ireg_of a1; OK(Addrmode None (Some(r1, sc)) (inr _ (id, ofs)))
+ | Ainstack n, nil =>
+ OK(Addrmode (Some RSP) None (inl _ (Ptrofs.signed n)))
+ | _, _ =>
+ Error(msg "Asmgen.transl_addressing")
+ end.
+
+Definition normalize_addrmode_32 (a: addrmode) :=
+ match a with
+ | Addrmode base ofs (inl n) =>
+ Addrmode base ofs (inl _ (Int.signed (Int.repr n)))
+ | Addrmode base ofs (inr _) =>
+ a
+ end.
+
+Definition normalize_addrmode_64 (a: addrmode) :=
+ match a with
+ | Addrmode base ofs (inl n) =>
+ let n' := Int.signed (Int.repr n) in
+ if zeq n' n
+ then (a, None)
+ else (Addrmode base ofs (inl _ 0), Some (Int64.repr n))
+ | Addrmode base ofs (inr _) =>
+ (a, None)
+ end.
+
+(** Floating-point comparison. We swap the operands in some cases
+ to simplify the handling of the unordered case. *)
+
+Definition floatcomp (cmp: comparison) (r1 r2: freg) : instruction :=
+ match cmp with
+ | Clt | Cle => Pcomisd_ff r2 r1
+ | Ceq | Cne | Cgt | Cge => Pcomisd_ff r1 r2
+ end.
+
+Definition floatcomp32 (cmp: comparison) (r1 r2: freg) : instruction :=
+ match cmp with
+ | Clt | Cle => Pcomiss_ff r2 r1
+ | Ceq | Cne | Cgt | Cge => Pcomiss_ff r1 r2
+ end.
+
+(** Translation of a condition. Prepends to [k] the instructions
+ that evaluate the condition and leave its boolean result in bits
+ of the condition register. *)
+
+Definition transl_cond
+ (cond: condition) (args: list mreg) (k: code) : res code :=
+ match cond, args with
+ | Ccomp c, a1 :: a2 :: nil =>
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (Pcmpl_rr r1 r2 :: k)
+ | Ccompu c, a1 :: a2 :: nil =>
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (Pcmpl_rr r1 r2 :: k)
+ | Ccompimm c n, a1 :: nil =>
+ do r1 <- ireg_of a1;
+ OK (if Int.eq_dec n Int.zero then Ptestl_rr r1 r1 :: k else Pcmpl_ri r1 n :: k)
+ | Ccompuimm c n, a1 :: nil =>
+ do r1 <- ireg_of a1; OK (Pcmpl_ri r1 n :: k)
+ | Ccompl c, a1 :: a2 :: nil =>
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (Pcmpq_rr r1 r2 :: k)
+ | Ccomplu c, a1 :: a2 :: nil =>
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (Pcmpq_rr r1 r2 :: k)
+ | Ccomplimm c n, a1 :: nil =>
+ do r1 <- ireg_of a1;
+ OK (if Int64.eq_dec n Int64.zero then Ptestq_rr r1 r1 :: k else Pcmpq_ri r1 n :: k)
+ | Ccompluimm c n, a1 :: nil =>
+ do r1 <- ireg_of a1; OK (Pcmpq_ri r1 n :: k)
+ | Ccompf cmp, a1 :: a2 :: nil =>
+ do r1 <- freg_of a1; do r2 <- freg_of a2; OK (floatcomp cmp r1 r2 :: k)
+ | Cnotcompf cmp, a1 :: a2 :: nil =>
+ do r1 <- freg_of a1; do r2 <- freg_of a2; OK (floatcomp cmp r1 r2 :: k)
+ | Ccompfs cmp, a1 :: a2 :: nil =>
+ do r1 <- freg_of a1; do r2 <- freg_of a2; OK (floatcomp32 cmp r1 r2 :: k)
+ | Cnotcompfs cmp, a1 :: a2 :: nil =>
+ do r1 <- freg_of a1; do r2 <- freg_of a2; OK (floatcomp32 cmp r1 r2 :: k)
+ | Cmaskzero n, a1 :: nil =>
+ do r1 <- ireg_of a1; OK (Ptestl_ri r1 n :: k)
+ | Cmasknotzero n, a1 :: nil =>
+ do r1 <- ireg_of a1; OK (Ptestl_ri r1 n :: k)
+ | _, _ =>
+ Error(msg "Asmgen.transl_cond")
+ end.
+
+(** What processor condition to test for a given Mach condition. *)
+
+Definition testcond_for_signed_comparison (cmp: comparison) :=
+ match cmp with
+ | Ceq => Cond_e
+ | Cne => Cond_ne
+ | Clt => Cond_l
+ | Cle => Cond_le
+ | Cgt => Cond_g
+ | Cge => Cond_ge
+ end.
+
+Definition testcond_for_unsigned_comparison (cmp: comparison) :=
+ match cmp with
+ | Ceq => Cond_e
+ | Cne => Cond_ne
+ | Clt => Cond_b
+ | Cle => Cond_be
+ | Cgt => Cond_a
+ | Cge => Cond_ae
+ end.
+
+Inductive extcond: Type :=
+ | Cond_base (c: testcond)
+ | Cond_or (c1 c2: testcond)
+ | Cond_and (c1 c2: testcond).
+
+Definition testcond_for_condition (cond: condition) : extcond :=
+ match cond with
+ | Ccomp c => Cond_base(testcond_for_signed_comparison c)
+ | Ccompu c => Cond_base(testcond_for_unsigned_comparison c)
+ | Ccompimm c n => Cond_base(testcond_for_signed_comparison c)
+ | Ccompuimm c n => Cond_base(testcond_for_unsigned_comparison c)
+ | Ccompl c => Cond_base(testcond_for_signed_comparison c)
+ | Ccomplu c => Cond_base(testcond_for_unsigned_comparison c)
+ | Ccomplimm c n => Cond_base(testcond_for_signed_comparison c)
+ | Ccompluimm c n => Cond_base(testcond_for_unsigned_comparison c)
+ | Ccompf c | Ccompfs c =>
+ match c with
+ | Ceq => Cond_and Cond_np Cond_e
+ | Cne => Cond_or Cond_p Cond_ne
+ | Clt => Cond_base Cond_a
+ | Cle => Cond_base Cond_ae
+ | Cgt => Cond_base Cond_a
+ | Cge => Cond_base Cond_ae
+ end
+ | Cnotcompf c | Cnotcompfs c =>
+ match c with
+ | Ceq => Cond_or Cond_p Cond_ne
+ | Cne => Cond_and Cond_np Cond_e
+ | Clt => Cond_base Cond_be
+ | Cle => Cond_base Cond_b
+ | Cgt => Cond_base Cond_be
+ | Cge => Cond_base Cond_b
+ end
+ | Cmaskzero n => Cond_base Cond_e
+ | Cmasknotzero n => Cond_base Cond_ne
+ end.
+
+(** Acting upon extended conditions. *)
+
+Definition mk_setcc_base (cond: extcond) (rd: ireg) (k: code) :=
+ match cond with
+ | Cond_base c =>
+ Psetcc c rd :: k
+ | Cond_and c1 c2 =>
+ if ireg_eq rd RAX
+ then Psetcc c1 RAX :: Psetcc c2 RCX :: Pandl_rr RAX RCX :: k
+ else Psetcc c1 RAX :: Psetcc c2 rd :: Pandl_rr rd RAX :: k
+ | Cond_or c1 c2 =>
+ if ireg_eq rd RAX
+ then Psetcc c1 RAX :: Psetcc c2 RCX :: Porl_rr RAX RCX :: k
+ else Psetcc c1 RAX :: Psetcc c2 rd :: Porl_rr rd RAX :: k
+ end.
+
+Definition mk_setcc (cond: extcond) (rd: ireg) (k: code) :=
+ if Archi.ptr64 || low_ireg rd
+ then mk_setcc_base cond rd k
+ else mk_setcc_base cond RAX (Pmov_rr rd RAX :: k).
+
+Definition mk_jcc (cond: extcond) (lbl: label) (k: code) :=
+ match cond with
+ | Cond_base c => Pjcc c lbl :: k
+ | Cond_and c1 c2 => Pjcc2 c1 c2 lbl :: k
+ | Cond_or c1 c2 => Pjcc c1 lbl :: Pjcc c2 lbl :: k
+ end.
+
+(** Translation of the arithmetic operation [r <- op(args)].
+ The corresponding instructions are prepended to [k]. *)
+
+Definition transl_op
+ (op: operation) (args: list mreg) (res: mreg) (k: code) : Errors.res code :=
+ match op, args with
+ | Omove, a1 :: nil =>
+ mk_mov (preg_of res) (preg_of a1) k
+ | Ointconst n, nil =>
+ do r <- ireg_of res;
+ OK ((if Int.eq_dec n Int.zero then Pxorl_r r else Pmovl_ri r n) :: k)
+ | Olongconst n, nil =>
+ do r <- ireg_of res;
+ OK ((if Int64.eq_dec n Int64.zero then Pxorq_r r else Pmovq_ri r n) :: k)
+ | Ofloatconst f, nil =>
+ do r <- freg_of res;
+ OK ((if Float.eq_dec f Float.zero then Pxorpd_f r else Pmovsd_fi r f) :: k)
+ | Osingleconst f, nil =>
+ do r <- freg_of res;
+ OK ((if Float32.eq_dec f Float32.zero then Pxorps_f r else Pmovss_fi r f) :: k)
+ | Oindirectsymbol id, nil =>
+ do r <- ireg_of res;
+ OK (Pmov_rs r id :: k)
+ | Ocast8signed, a1 :: nil =>
+ do r1 <- ireg_of a1; do r <- ireg_of res; mk_intconv Pmovsb_rr r r1 k
+ | Ocast8unsigned, a1 :: nil =>
+ do r1 <- ireg_of a1; do r <- ireg_of res; mk_intconv Pmovzb_rr r r1 k
+ | Ocast16signed, a1 :: nil =>
+ do r1 <- ireg_of a1; do r <- ireg_of res; OK (Pmovsw_rr r r1 :: k)
+ | Ocast16unsigned, a1 :: nil =>
+ do r1 <- ireg_of a1; do r <- ireg_of res; OK (Pmovzw_rr r r1 :: k)
+ | Oneg, a1 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Pnegl r :: k)
+ | Osub, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; do r2 <- ireg_of a2; OK (Psubl_rr r r2 :: k)
+ | Omul, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pimull_rr r r2 :: k)
+ | Omulimm n, a1 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Pimull_ri r n :: k)
+ | Omulhs, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 AX);
+ assertion (mreg_eq res DX);
+ do r2 <- ireg_of a2; OK (Pimull_r r2 :: k)
+ | Omulhu, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 AX);
+ assertion (mreg_eq res DX);
+ do r2 <- ireg_of a2; OK (Pmull_r r2 :: k)
+ | Odiv, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 AX);
+ assertion (mreg_eq a2 CX);
+ assertion (mreg_eq res AX);
+ OK(Pcltd :: Pidivl RCX :: k)
+ | Odivu, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 AX);
+ assertion (mreg_eq a2 CX);
+ assertion (mreg_eq res AX);
+ OK(Pxorl_r RDX :: Pdivl RCX :: k)
+ | Omod, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 AX);
+ assertion (mreg_eq a2 CX);
+ assertion (mreg_eq res DX);
+ OK(Pcltd :: Pidivl RCX :: k)
+ | Omodu, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 AX);
+ assertion (mreg_eq a2 CX);
+ assertion (mreg_eq res DX);
+ OK(Pxorl_r RDX :: Pdivl RCX :: k)
+ | Oand, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pandl_rr r r2 :: k)
+ | Oandimm n, a1 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Pandl_ri r n :: k)
+ | Oor, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; do r2 <- ireg_of a2; OK (Porl_rr r r2 :: k)
+ | Oorimm n, a1 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Porl_ri r n :: k)
+ | Oxor, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pxorl_rr r r2 :: k)
+ | Oxorimm n, a1 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Pxorl_ri r n :: k)
+ | Onot, a1 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Pnotl r :: k)
+ | Oshl, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 res);
+ assertion (mreg_eq a2 CX);
+ do r <- ireg_of res; OK (Psall_rcl r :: k)
+ | Oshlimm n, a1 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Psall_ri r n :: k)
+ | Oshr, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 res);
+ assertion (mreg_eq a2 CX);
+ do r <- ireg_of res; OK (Psarl_rcl r :: k)
+ | Oshrimm n, a1 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Psarl_ri r n :: k)
+ | Oshru, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 res);
+ assertion (mreg_eq a2 CX);
+ do r <- ireg_of res; OK (Pshrl_rcl r :: k)
+ | Oshruimm n, a1 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Pshrl_ri r n :: k)
+ | Oshrximm n, a1 :: nil =>
+ assertion (mreg_eq a1 AX);
+ assertion (mreg_eq res AX);
+ mk_shrximm n k
+ | Ororimm n, a1 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Prorl_ri r n :: k)
+ | Oshldimm n, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pshld_ri r r2 n :: k)
+ | Olea addr, _ =>
+ do am <- transl_addressing addr args; do r <- ireg_of res;
+ OK (Pleal r (normalize_addrmode_32 am) :: k)
+(* 64-bit integer operations *)
+ | Olowlong, a1 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Pmovls_rr r :: k)
+ | Ocast32signed, a1 :: nil =>
+ do r1 <- ireg_of a1; do r <- ireg_of res; OK (Pmovsl_rr r r1 :: k)
+ | Ocast32unsigned, a1 :: nil =>
+ do r1 <- ireg_of a1; do r <- ireg_of res; OK (Pmovzl_rr r r1 :: k)
+ | Onegl, a1 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Pnegq r :: k)
+ | Oaddlimm n, a1 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Paddq_ri r n :: k)
+ | Osubl, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; do r2 <- ireg_of a2; OK (Psubq_rr r r2 :: k)
+ | Omull, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pimulq_rr r r2 :: k)
+ | Omullimm n, a1 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Pimulq_ri r n :: k)
+ | Omullhs, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 AX);
+ assertion (mreg_eq res DX);
+ do r2 <- ireg_of a2; OK (Pimulq_r r2 :: k)
+ | Omullhu, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 AX);
+ assertion (mreg_eq res DX);
+ do r2 <- ireg_of a2; OK (Pmulq_r r2 :: k)
+ | Odivl, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 AX);
+ assertion (mreg_eq a2 CX);
+ assertion (mreg_eq res AX);
+ OK(Pcqto :: Pidivq RCX :: k)
+ | Odivlu, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 AX);
+ assertion (mreg_eq a2 CX);
+ assertion (mreg_eq res AX);
+ OK(Pxorq_r RDX :: Pdivq RCX :: k)
+ | Omodl, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 AX);
+ assertion (mreg_eq a2 CX);
+ assertion (mreg_eq res DX);
+ OK(Pcqto :: Pidivq RCX :: k)
+ | Omodlu, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 AX);
+ assertion (mreg_eq a2 CX);
+ assertion (mreg_eq res DX);
+ OK(Pxorq_r RDX :: Pdivq RCX :: k)
+ | Oandl, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pandq_rr r r2 :: k)
+ | Oandlimm n, a1 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Pandq_ri r n :: k)
+ | Oorl, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; do r2 <- ireg_of a2; OK (Porq_rr r r2 :: k)
+ | Oorlimm n, a1 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Porq_ri r n :: k)
+ | Oxorl, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pxorq_rr r r2 :: k)
+ | Oxorlimm n, a1 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Pxorq_ri r n :: k)
+ | Onotl, a1 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Pnotq r :: k)
+ | Oshll, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 res);
+ assertion (mreg_eq a2 CX);
+ do r <- ireg_of res; OK (Psalq_rcl r :: k)
+ | Oshllimm n, a1 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Psalq_ri r n :: k)
+ | Oshrl, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 res);
+ assertion (mreg_eq a2 CX);
+ do r <- ireg_of res; OK (Psarq_rcl r :: k)
+ | Oshrlimm n, a1 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Psarq_ri r n :: k)
+ | Oshrxlimm n, a1 :: nil =>
+ assertion (mreg_eq a1 AX);
+ assertion (mreg_eq res AX);
+ mk_shrxlimm n k
+ | Oshrlu, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 res);
+ assertion (mreg_eq a2 CX);
+ do r <- ireg_of res; OK (Pshrq_rcl r :: k)
+ | Oshrluimm n, a1 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Pshrq_ri r n :: k)
+ | Ororlimm n, a1 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; OK (Prorq_ri r n :: k)
+ | Oleal addr, _ =>
+ do am <- transl_addressing addr args; do r <- ireg_of res;
+ OK (match normalize_addrmode_64 am with
+ | (am', None) => Pleaq r am' :: k
+ | (am', Some delta) => Pleaq r am' :: Paddq_ri r delta :: k
+ end)
+(**)
+ | Onegf, a1 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- freg_of res; OK (Pnegd r :: k)
+ | Oabsf, a1 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- freg_of res; OK (Pabsd r :: k)
+ | Oaddf, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- freg_of res; do r2 <- freg_of a2; OK (Paddd_ff r r2 :: k)
+ | Osubf, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- freg_of res; do r2 <- freg_of a2; OK (Psubd_ff r r2 :: k)
+ | Omulf, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- freg_of res; do r2 <- freg_of a2; OK (Pmuld_ff r r2 :: k)
+ | Odivf, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- freg_of res; do r2 <- freg_of a2; OK (Pdivd_ff r r2 :: k)
+ | Onegfs, a1 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- freg_of res; OK (Pnegs r :: k)
+ | Oabsfs, a1 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- freg_of res; OK (Pabss r :: k)
+ | Oaddfs, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- freg_of res; do r2 <- freg_of a2; OK (Padds_ff r r2 :: k)
+ | Osubfs, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- freg_of res; do r2 <- freg_of a2; OK (Psubs_ff r r2 :: k)
+ | Omulfs, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- freg_of res; do r2 <- freg_of a2; OK (Pmuls_ff r r2 :: k)
+ | Odivfs, a1 :: a2 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r <- freg_of res; do r2 <- freg_of a2; OK (Pdivs_ff r r2 :: k)
+ | Osingleoffloat, a1 :: nil =>
+ do r <- freg_of res; do r1 <- freg_of a1; OK (Pcvtsd2ss_ff r r1 :: k)
+ | Ofloatofsingle, a1 :: nil =>
+ do r <- freg_of res; do r1 <- freg_of a1; OK (Pcvtss2sd_ff r r1 :: k)
+ | Ointoffloat, a1 :: nil =>
+ do r <- ireg_of res; do r1 <- freg_of a1; OK (Pcvttsd2si_rf r r1 :: k)
+ | Ofloatofint, a1 :: nil =>
+ do r <- freg_of res; do r1 <- ireg_of a1; OK (Pcvtsi2sd_fr r r1 :: k)
+ | Ointofsingle, a1 :: nil =>
+ do r <- ireg_of res; do r1 <- freg_of a1; OK (Pcvttss2si_rf r r1 :: k)
+ | Osingleofint, a1 :: nil =>
+ do r <- freg_of res; do r1 <- ireg_of a1; OK (Pcvtsi2ss_fr r r1 :: k)
+ | Olongoffloat, a1 :: nil =>
+ do r <- ireg_of res; do r1 <- freg_of a1; OK (Pcvttsd2sl_rf r r1 :: k)
+ | Ofloatoflong, a1 :: nil =>
+ do r <- freg_of res; do r1 <- ireg_of a1; OK (Pcvtsl2sd_fr r r1 :: k)
+ | Olongofsingle, a1 :: nil =>
+ do r <- ireg_of res; do r1 <- freg_of a1; OK (Pcvttss2sl_rf r r1 :: k)
+ | Osingleoflong, a1 :: nil =>
+ do r <- freg_of res; do r1 <- ireg_of a1; OK (Pcvtsl2ss_fr r r1 :: k)
+ | Ocmp c, args =>
+ do r <- ireg_of res;
+ transl_cond c args (mk_setcc (testcond_for_condition c) r k)
+ | _, _ =>
+ Error(msg "Asmgen.transl_op")
+ end.
+
+(** Translation of memory loads and stores *)
+
+Definition transl_load (chunk: memory_chunk)
+ (addr: addressing) (args: list mreg) (dest: mreg)
+ (k: code) : res code :=
+ do am <- transl_addressing addr args;
+ match chunk with
+ | Mint8unsigned =>
+ do r <- ireg_of dest; OK(Pmovzb_rm r am :: k)
+ | Mint8signed =>
+ do r <- ireg_of dest; OK(Pmovsb_rm r am :: k)
+ | Mint16unsigned =>
+ do r <- ireg_of dest; OK(Pmovzw_rm r am :: k)
+ | Mint16signed =>
+ do r <- ireg_of dest; OK(Pmovsw_rm r am :: k)
+ | Mint32 =>
+ do r <- ireg_of dest; OK(Pmovl_rm r am :: k)
+ | Mint64 =>
+ do r <- ireg_of dest; OK(Pmovq_rm r am :: k)
+ | Mfloat32 =>
+ do r <- freg_of dest; OK(Pmovss_fm r am :: k)
+ | Mfloat64 =>
+ do r <- freg_of dest; OK(Pmovsd_fm r am :: k)
+ | _ =>
+ Error (msg "Asmgen.transl_load")
+ end.
+
+Definition transl_store (chunk: memory_chunk)
+ (addr: addressing) (args: list mreg) (src: mreg)
+ (k: code) : res code :=
+ do am <- transl_addressing addr args;
+ match chunk with
+ | Mint8unsigned | Mint8signed =>
+ do r <- ireg_of src; mk_storebyte am r k
+ | Mint16unsigned | Mint16signed =>
+ do r <- ireg_of src; OK(Pmovw_mr am r :: k)
+ | Mint32 =>
+ do r <- ireg_of src; OK(Pmovl_mr am r :: k)
+ | Mint64 =>
+ do r <- ireg_of src; OK(Pmovq_mr am r :: k)
+ | Mfloat32 =>
+ do r <- freg_of src; OK(Pmovss_mf am r :: k)
+ | Mfloat64 =>
+ do r <- freg_of src; OK(Pmovsd_mf am r :: k)
+ | _ =>
+ Error (msg "Asmgen.transl_store")
+ end.
+
+(** Translation of a Mach instruction. *)
+
+Definition transl_instr (f: Mach.function) (i: Mach.instruction)
+ (ax_is_parent: bool) (k: code) :=
+ match i with
+ | Mgetstack ofs ty dst =>
+ loadind RSP ofs ty dst k
+ | Msetstack src ofs ty =>
+ storeind src RSP ofs ty k
+ | Mgetparam ofs ty dst =>
+ if ax_is_parent then
+ loadind RAX ofs ty dst k
+ else
+ (do k1 <- loadind RAX ofs ty dst k;
+ loadind RSP f.(fn_link_ofs) Tptr AX k1)
+ | Mop op args res =>
+ transl_op op args res k
+ | Mload chunk addr args dst =>
+ transl_load chunk addr args dst k
+ | Mstore chunk addr args src =>
+ transl_store chunk addr args src k
+ | Mcall sig (inl reg) =>
+ do r <- ireg_of reg; OK (Pcall_r r sig :: k)
+ | Mcall sig (inr symb) =>
+ OK (Pcall_s symb sig :: k)
+ | Mtailcall sig (inl reg) =>
+ do r <- ireg_of reg;
+ OK (Pfreeframe f.(fn_stacksize) f.(fn_retaddr_ofs) f.(fn_link_ofs) ::
+ Pjmp_r r sig :: k)
+ | Mtailcall sig (inr symb) =>
+ OK (Pfreeframe f.(fn_stacksize) f.(fn_retaddr_ofs) f.(fn_link_ofs) ::
+ Pjmp_s symb sig :: k)
+ | Mlabel lbl =>
+ OK(Plabel lbl :: k)
+ | Mgoto lbl =>
+ OK(Pjmp_l lbl :: k)
+ | Mcond cond args lbl =>
+ transl_cond cond args (mk_jcc (testcond_for_condition cond) lbl k)
+ | Mjumptable arg tbl =>
+ do r <- ireg_of arg; OK (Pjmptbl r tbl :: k)
+ | Mreturn =>
+ OK (Pfreeframe f.(fn_stacksize) f.(fn_retaddr_ofs) f.(fn_link_ofs) ::
+ Pret :: k)
+ | Mbuiltin ef args res =>
+ OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) :: k)
+ end.
+
+(** Translation of a code sequence *)
+
+Definition it1_is_parent (before: bool) (i: Mach.instruction) : bool :=
+ match i with
+ | Msetstack src ofs ty => before
+ | Mgetparam ofs ty dst => negb (mreg_eq dst AX)
+ | _ => false
+ end.
+
+(** This is the naive definition that we no longer use because it
+ is not tail-recursive. It is kept as specification. *)
+
+Fixpoint transl_code (f: Mach.function) (il: list Mach.instruction) (axp: bool) :=
+ match il with
+ | nil => OK nil
+ | i1 :: il' =>
+ do k <- transl_code f il' (it1_is_parent axp i1);
+ transl_instr f i1 axp k
+ end.
+
+(** This is an equivalent definition in continuation-passing style
+ that runs in constant stack space. *)
+
+Fixpoint transl_code_rec (f: Mach.function) (il: list Mach.instruction)
+ (axp: bool) (k: code -> res code) :=
+ match il with
+ | nil => k nil
+ | i1 :: il' =>
+ transl_code_rec f il' (it1_is_parent axp i1)
+ (fun c1 => do c2 <- transl_instr f i1 axp c1; k c2)
+ end.
+
+Definition transl_code' (f: Mach.function) (il: list Mach.instruction) (axp: bool) :=
+ transl_code_rec f il axp (fun c => OK c).
+
+(** Translation of a whole function. Note that we must check
+ that the generated code contains less than [2^32] instructions,
+ otherwise the offset part of the [PC] code pointer could wrap
+ around, leading to incorrect executions. *)
+
+Definition transl_function (f: Mach.function) :=
+ do c <- transl_code' f f.(Mach.fn_code) true;
+ OK (mkfunction f.(Mach.fn_sig)
+ (Pallocframe f.(fn_stacksize) f.(fn_retaddr_ofs) f.(fn_link_ofs) :: c)).
+
+Definition transf_function (f: Mach.function) : res Asm.function :=
+ do tf <- transl_function f;
+ if zlt Ptrofs.max_unsigned (list_length_z tf.(fn_code))
+ then Error (msg "code size exceeded")
+ else OK tf.
+
+Definition transf_fundef (f: Mach.fundef) : res Asm.fundef :=
+ transf_partial_fundef transf_function f.
+
+Definition transf_program (p: Mach.program) : res Asm.program :=
+ transform_partial_program transf_fundef p.
+
diff --git a/x86/Asmgenproof.v b/x86/Asmgenproof.v
new file mode 100644
index 00000000..e56dc429
--- /dev/null
+++ b/x86/Asmgenproof.v
@@ -0,0 +1,916 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris *)
+(* *)
+(* 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 x86-64 generation: main proof. *)
+
+Require Import Coqlib Errors.
+Require Import Integers Floats AST Linking.
+Require Import Values Memory Events Globalenvs Smallstep.
+Require Import Op Locations Mach Conventions Asm.
+Require Import Asmgen Asmgenproof0 Asmgenproof1.
+
+Definition match_prog (p: Mach.program) (tp: Asm.program) :=
+ match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp.
+
+Lemma transf_program_match:
+ forall p tp, transf_program p = OK tp -> match_prog p tp.
+Proof.
+ intros. eapply match_transform_partial_program; eauto.
+Qed.
+
+Section PRESERVATION.
+
+Variable prog: Mach.program.
+Variable tprog: Asm.program.
+Hypothesis TRANSF: match_prog prog tprog.
+Let ge := Genv.globalenv prog.
+Let tge := Genv.globalenv tprog.
+
+Lemma symbols_preserved:
+ forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
+Proof (Genv.find_symbol_match TRANSF).
+
+Lemma senv_preserved:
+ Senv.equiv ge tge.
+Proof (Genv.senv_match TRANSF).
+
+Lemma functions_translated:
+ forall b f,
+ Genv.find_funct_ptr ge b = Some f ->
+ exists tf,
+ Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf.
+Proof (Genv.find_funct_ptr_transf_partial TRANSF).
+
+Lemma functions_transl:
+ forall fb f tf,
+ Genv.find_funct_ptr ge fb = Some (Internal f) ->
+ transf_function f = OK tf ->
+ Genv.find_funct_ptr tge fb = Some (Internal tf).
+Proof.
+ intros. exploit functions_translated; eauto. intros [tf' [A B]].
+ monadInv B. rewrite H0 in EQ; inv EQ; auto.
+Qed.
+
+(** * Properties of control flow *)
+
+Lemma transf_function_no_overflow:
+ forall f tf,
+ transf_function f = OK tf -> list_length_z (fn_code tf) <= Ptrofs.max_unsigned.
+Proof.
+ intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z (fn_code x))); monadInv EQ0.
+ omega.
+Qed.
+
+Lemma exec_straight_exec:
+ forall fb f c ep tf tc c' rs m rs' m',
+ transl_code_at_pc ge (rs PC) fb f c ep tf tc ->
+ exec_straight tge tf tc rs m c' rs' m' ->
+ plus step tge (State rs m) E0 (State rs' m').
+Proof.
+ intros. inv H.
+ eapply exec_straight_steps_1; eauto.
+ eapply transf_function_no_overflow; eauto.
+ eapply functions_transl; eauto.
+Qed.
+
+Lemma exec_straight_at:
+ forall fb f c ep tf tc c' ep' tc' rs m rs' m',
+ transl_code_at_pc ge (rs PC) fb f c ep tf tc ->
+ transl_code f c' ep' = OK tc' ->
+ exec_straight tge tf tc rs m tc' rs' m' ->
+ transl_code_at_pc ge (rs' PC) fb f c' ep' tf tc'.
+Proof.
+ intros. inv H.
+ exploit exec_straight_steps_2; eauto.
+ eapply transf_function_no_overflow; eauto.
+ eapply functions_transl; eauto.
+ intros [ofs' [PC' CT']].
+ rewrite PC'. constructor; auto.
+Qed.
+
+(** The following lemmas show that the translation from Mach to Asm
+ preserves labels, in the sense that the following diagram commutes:
+<<
+ translation
+ Mach code ------------------------ Asm instr sequence
+ | |
+ | Mach.find_label lbl find_label lbl |
+ | |
+ v v
+ Mach code tail ------------------- Asm instr seq tail
+ translation
+>>
+ The proof demands many boring lemmas showing that Asm constructor
+ functions do not introduce new labels.
+
+ In passing, we also prove a "is tail" property of the generated Asm code.
+*)
+
+Section TRANSL_LABEL.
+
+Remark mk_mov_label:
+ forall rd rs k c, mk_mov rd rs k = OK c -> tail_nolabel k c.
+Proof.
+ unfold mk_mov; intros.
+ destruct rd; try discriminate; destruct rs; TailNoLabel.
+Qed.
+Hint Resolve mk_mov_label: labels.
+
+Remark mk_shrximm_label:
+ forall n k c, mk_shrximm n k = OK c -> tail_nolabel k c.
+Proof.
+ intros. monadInv H; TailNoLabel.
+Qed.
+Hint Resolve mk_shrximm_label: labels.
+
+Remark mk_shrxlimm_label:
+ forall n k c, mk_shrxlimm n k = OK c -> tail_nolabel k c.
+Proof.
+ intros. monadInv H. destruct (Int.eq n Int.zero); TailNoLabel.
+Qed.
+Hint Resolve mk_shrxlimm_label: labels.
+
+Remark mk_intconv_label:
+ forall f r1 r2 k c, mk_intconv f r1 r2 k = OK c ->
+ (forall r r', nolabel (f r r')) ->
+ tail_nolabel k c.
+Proof.
+ unfold mk_intconv; intros. TailNoLabel.
+Qed.
+Hint Resolve mk_intconv_label: labels.
+
+Remark mk_storebyte_label:
+ forall addr r k c, mk_storebyte addr r k = OK c -> tail_nolabel k c.
+Proof.
+ unfold mk_storebyte; intros. TailNoLabel.
+Qed.
+Hint Resolve mk_storebyte_label: labels.
+
+Remark loadind_label:
+ forall base ofs ty dst k c,
+ loadind base ofs ty dst k = OK c ->
+ tail_nolabel k c.
+Proof.
+ unfold loadind; intros. destruct ty; try discriminate; destruct (preg_of dst); TailNoLabel.
+Qed.
+
+Remark storeind_label:
+ forall base ofs ty src k c,
+ storeind src base ofs ty k = OK c ->
+ tail_nolabel k c.
+Proof.
+ unfold storeind; intros. destruct ty; try discriminate; destruct (preg_of src); TailNoLabel.
+Qed.
+
+Remark mk_setcc_base_label:
+ forall xc rd k,
+ tail_nolabel k (mk_setcc_base xc rd k).
+Proof.
+ intros. destruct xc; simpl; destruct (ireg_eq rd RAX); TailNoLabel.
+Qed.
+
+Remark mk_setcc_label:
+ forall xc rd k,
+ tail_nolabel k (mk_setcc xc rd k).
+Proof.
+ intros. unfold mk_setcc. destruct (Archi.ptr64 || low_ireg rd).
+ apply mk_setcc_base_label.
+ eapply tail_nolabel_trans. apply mk_setcc_base_label. TailNoLabel.
+Qed.
+
+Remark mk_jcc_label:
+ forall xc lbl' k,
+ tail_nolabel k (mk_jcc xc lbl' k).
+Proof.
+ intros. destruct xc; simpl; TailNoLabel.
+Qed.
+
+Remark transl_cond_label:
+ forall cond args k c,
+ transl_cond cond args k = OK c ->
+ tail_nolabel k c.
+Proof.
+ unfold transl_cond; intros.
+ destruct cond; TailNoLabel.
+ destruct (Int.eq_dec n Int.zero); TailNoLabel.
+ destruct (Int64.eq_dec n Int64.zero); TailNoLabel.
+ destruct c0; simpl; TailNoLabel.
+ destruct c0; simpl; TailNoLabel.
+ destruct c0; simpl; TailNoLabel.
+ destruct c0; simpl; TailNoLabel.
+Qed.
+
+Remark transl_op_label:
+ forall op args r k c,
+ transl_op op args r k = OK c ->
+ tail_nolabel k c.
+Proof.
+ unfold transl_op; intros. destruct op; TailNoLabel.
+ destruct (Int.eq_dec n Int.zero); TailNoLabel.
+ destruct (Int64.eq_dec n Int64.zero); TailNoLabel.
+ destruct (Float.eq_dec n Float.zero); TailNoLabel.
+ destruct (Float32.eq_dec n Float32.zero); TailNoLabel.
+ destruct (normalize_addrmode_64 x) as [am' [delta|]]; TailNoLabel.
+ eapply tail_nolabel_trans. eapply transl_cond_label; eauto. eapply mk_setcc_label.
+Qed.
+
+Remark transl_load_label:
+ forall chunk addr args dest k c,
+ transl_load chunk addr args dest k = OK c ->
+ tail_nolabel k c.
+Proof.
+ intros. monadInv H. destruct chunk; TailNoLabel.
+Qed.
+
+Remark transl_store_label:
+ forall chunk addr args src k c,
+ transl_store chunk addr args src k = OK c ->
+ tail_nolabel k c.
+Proof.
+ intros. monadInv H. destruct chunk; TailNoLabel.
+Qed.
+
+Lemma transl_instr_label:
+ forall f i ep k c,
+ transl_instr f i ep k = OK c ->
+ match i with Mlabel lbl => c = Plabel lbl :: k | _ => tail_nolabel k c end.
+Proof.
+Opaque loadind.
+ unfold transl_instr; intros; destruct i; TailNoLabel.
+ eapply loadind_label; eauto.
+ eapply storeind_label; eauto.
+ eapply loadind_label; eauto.
+ eapply tail_nolabel_trans; eapply loadind_label; eauto.
+ eapply transl_op_label; eauto.
+ eapply transl_load_label; eauto.
+ eapply transl_store_label; eauto.
+ destruct s0; TailNoLabel.
+ destruct s0; TailNoLabel.
+ eapply tail_nolabel_trans. eapply transl_cond_label; eauto. eapply mk_jcc_label.
+Qed.
+
+Lemma transl_instr_label':
+ forall lbl f i ep k c,
+ transl_instr f i ep k = OK c ->
+ find_label lbl c = if Mach.is_label lbl i then Some k else find_label lbl k.
+Proof.
+ intros. exploit transl_instr_label; eauto.
+ destruct i; try (intros [A B]; apply B).
+ intros. subst c. simpl. auto.
+Qed.
+
+Lemma transl_code_label:
+ forall lbl f c ep tc,
+ transl_code f c ep = OK tc ->
+ match Mach.find_label lbl c with
+ | None => find_label lbl tc = None
+ | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_code f c' false = OK tc'
+ end.
+Proof.
+ induction c; simpl; intros.
+ inv H. auto.
+ monadInv H. rewrite (transl_instr_label' lbl _ _ _ _ _ EQ0).
+ generalize (Mach.is_label_correct lbl a).
+ destruct (Mach.is_label lbl a); intros.
+ subst a. simpl in EQ. exists x; auto.
+ eapply IHc; eauto.
+Qed.
+
+Lemma transl_find_label:
+ forall lbl f tf,
+ transf_function f = OK tf ->
+ match Mach.find_label lbl f.(Mach.fn_code) with
+ | None => find_label lbl tf.(fn_code) = None
+ | Some c => exists tc, find_label lbl tf.(fn_code) = Some tc /\ transl_code f c false = OK tc
+ end.
+Proof.
+ intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z (fn_code x))); inv EQ0.
+ monadInv EQ. simpl. eapply transl_code_label; eauto. rewrite transl_code'_transl_code in EQ0; eauto.
+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 tf lbl rs m c' b ofs,
+ Genv.find_funct_ptr ge b = Some (Internal f) ->
+ transf_function f = OK tf ->
+ rs PC = Vptr b ofs ->
+ Mach.find_label lbl f.(Mach.fn_code) = Some c' ->
+ exists tc', exists rs',
+ goto_label tf lbl rs m = Next rs' m
+ /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc'
+ /\ forall r, r <> PC -> rs'#r = rs#r.
+Proof.
+ intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2.
+ intros [tc [A B]].
+ exploit label_pos_code_tail; eauto. instantiate (1 := 0).
+ intros [pos' [P [Q R]]].
+ exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))).
+ split. unfold goto_label. rewrite P. rewrite H1. auto.
+ split. rewrite Pregmap.gss. constructor; auto.
+ rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q.
+ auto. omega.
+ generalize (transf_function_no_overflow _ _ H0). omega.
+ intros. apply Pregmap.gso; auto.
+Qed.
+
+(** Existence of return addresses *)
+
+Lemma return_address_exists:
+ forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) ->
+ exists ra, return_address_offset f c ra.
+Proof.
+ intros. eapply Asmgenproof0.return_address_exists; eauto.
+- intros. exploit transl_instr_label; eauto.
+ destruct i; try (intros [A B]; apply A). intros. subst c0. repeat constructor.
+- intros. monadInv H0.
+ destruct (zlt Ptrofs.max_unsigned (list_length_z (fn_code x))); inv EQ0.
+ monadInv EQ. rewrite transl_code'_transl_code in EQ0.
+ exists x; exists true; split; auto. unfold fn_code. repeat constructor.
+- exact transf_function_no_overflow.
+Qed.
+
+(** * Proof of semantic preservation *)
+
+(** Semantic preservation is proved using simulation diagrams
+ of the following form.
+<<
+ st1 --------------- st2
+ | |
+ t| *|t
+ | |
+ v v
+ st1'--------------- st2'
+>>
+ The invariant is the [match_states] predicate below, which includes:
+- The 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_states: Mach.state -> Asm.state -> Prop :=
+ | match_states_intro:
+ forall s fb sp c ep ms m m' rs f tf tc
+ (STACKS: match_stack ge s)
+ (FIND: Genv.find_funct_ptr ge fb = Some (Internal f))
+ (MEXT: Mem.extends m m')
+ (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc)
+ (AG: agree ms sp rs)
+ (AXP: ep = true -> rs#RAX = parent_sp s),
+ match_states (Mach.State s fb sp c ms m)
+ (Asm.State rs m')
+ | match_states_call:
+ forall s fb ms m m' rs
+ (STACKS: match_stack ge s)
+ (MEXT: Mem.extends m m')
+ (AG: agree ms (parent_sp s) rs)
+ (ATPC: rs PC = Vptr fb Ptrofs.zero)
+ (ATLR: rs RA = parent_ra s),
+ match_states (Mach.Callstate s fb ms m)
+ (Asm.State rs m')
+ | match_states_return:
+ forall s ms m m' rs
+ (STACKS: match_stack ge s)
+ (MEXT: Mem.extends m m')
+ (AG: agree ms (parent_sp s) rs)
+ (ATPC: rs PC = parent_ra s),
+ match_states (Mach.Returnstate s ms m)
+ (Asm.State rs m').
+
+Lemma exec_straight_steps:
+ forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2,
+ match_stack ge s ->
+ Mem.extends m2 m2' ->
+ Genv.find_funct_ptr ge fb = Some (Internal f) ->
+ transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc ->
+ (forall k c (TR: transl_instr f i ep k = OK c),
+ exists rs2,
+ exec_straight tge tf c rs1 m1' k rs2 m2'
+ /\ agree ms2 sp rs2
+ /\ (it1_is_parent ep i = true -> rs2#RAX = parent_sp s)) ->
+ exists st',
+ plus step tge (State rs1 m1') E0 st' /\
+ match_states (Mach.State s fb sp c ms2 m2) st'.
+Proof.
+ intros. inversion H2. subst. monadInv H7.
+ exploit H3; eauto. intros [rs2 [A [B C]]].
+ exists (State rs2 m2'); split.
+ eapply exec_straight_exec; eauto.
+ econstructor; eauto. eapply exec_straight_at; eauto.
+Qed.
+
+Lemma exec_straight_steps_goto:
+ forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c',
+ match_stack ge s ->
+ Mem.extends m2 m2' ->
+ Genv.find_funct_ptr ge fb = Some (Internal f) ->
+ Mach.find_label lbl f.(Mach.fn_code) = Some c' ->
+ transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc ->
+ it1_is_parent ep i = false ->
+ (forall k c (TR: transl_instr f i ep k = OK c),
+ exists jmp, exists k', exists rs2,
+ exec_straight tge tf c rs1 m1' (jmp :: k') rs2 m2'
+ /\ agree ms2 sp rs2
+ /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') ->
+ exists st',
+ plus step tge (State rs1 m1') E0 st' /\
+ match_states (Mach.State s fb sp c' ms2 m2) st'.
+Proof.
+ intros. inversion H3. subst. monadInv H9.
+ exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]].
+ generalize (functions_transl _ _ _ H7 H8); intro FN.
+ generalize (transf_function_no_overflow _ _ H8); intro NOOV.
+ exploit exec_straight_steps_2; eauto.
+ intros [ofs' [PC2 CT2]].
+ exploit find_label_goto_label; eauto.
+ intros [tc' [rs3 [GOTO [AT' OTH]]]].
+ exists (State rs3 m2'); split.
+ eapply plus_right'.
+ eapply exec_straight_steps_1; eauto.
+ econstructor; eauto.
+ eapply find_instr_tail. eauto.
+ rewrite C. eexact GOTO.
+ traceEq.
+ econstructor; eauto.
+ apply agree_exten with rs2; auto with asmgen.
+ congruence.
+Qed.
+
+(** 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 Asm transition, except the
+ transition from [Mach.Returnstate] to [Mach.State].
+ So, the following integer measure will suffice to rule out
+ the unwanted behaviour. *)
+
+Definition measure (s: Mach.state) : nat :=
+ match s with
+ | Mach.State _ _ _ _ _ _ => 0%nat
+ | Mach.Callstate _ _ _ _ => 0%nat
+ | Mach.Returnstate _ _ _ => 1%nat
+ end.
+
+(** This is the simulation diagram. We prove it by case analysis on the Mach transition. *)
+
+Theorem step_simulation:
+ forall S1 t S2, Mach.step return_address_offset ge S1 t S2 ->
+ forall S1' (MS: match_states S1 S1'),
+ (exists S2', plus step tge S1' t S2' /\ match_states S2 S2')
+ \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat.
+Proof.
+ induction 1; intros; inv MS.
+
+- (* Mlabel *)
+ left; eapply exec_straight_steps; eauto; intros.
+ monadInv TR. econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ split. apply agree_nextinstr; auto. simpl; congruence.
+
+- (* Mgetstack *)
+ unfold load_stack in H.
+ exploit Mem.loadv_extends; eauto. intros [v' [A B]].
+ rewrite (sp_val _ _ _ AG) in A.
+ left; eapply exec_straight_steps; eauto. intros. simpl in TR.
+ exploit loadind_correct; eauto. intros [rs' [P [Q R]]].
+ exists rs'; split. eauto.
+ split. eapply agree_set_mreg; eauto. congruence.
+ simpl; congruence.
+
+- (* Msetstack *)
+ unfold store_stack in H.
+ assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto.
+ exploit Mem.storev_extends; eauto. intros [m2' [A B]].
+ left; eapply exec_straight_steps; eauto.
+ rewrite (sp_val _ _ _ AG) in A. intros. simpl in TR.
+ exploit storeind_correct; eauto. intros [rs' [P Q]].
+ exists rs'; split. eauto.
+ split. eapply agree_undef_regs; eauto.
+ simpl; intros. rewrite Q; auto with asmgen.
+Local Transparent destroyed_by_setstack.
+ destruct ty; simpl; intuition congruence.
+
+- (* Mgetparam *)
+ assert (f0 = f) by congruence; subst f0.
+ unfold load_stack in *.
+ exploit Mem.loadv_extends. eauto. eexact H0. auto.
+ intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A.
+ exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'.
+ exploit Mem.loadv_extends. eauto. eexact H1. auto.
+ intros [v' [C D]].
+Opaque loadind.
+ left; eapply exec_straight_steps; eauto; intros.
+ assert (DIFF: negb (mreg_eq dst AX) = true -> IR RAX <> preg_of dst).
+ intros. change (IR RAX) with (preg_of AX). red; intros.
+ unfold proj_sumbool in H1. destruct (mreg_eq dst AX); try discriminate.
+ elim n. eapply preg_of_injective; eauto.
+ destruct ep; simpl in TR.
+(* RAX contains parent *)
+ exploit loadind_correct. eexact TR.
+ instantiate (2 := rs0). rewrite AXP; eauto.
+ intros [rs1 [P [Q R]]].
+ exists rs1; split. eauto.
+ split. eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto.
+ simpl; intros. rewrite R; auto.
+(* RAX does not contain parent *)
+ monadInv TR.
+ exploit loadind_correct. eexact EQ0. eauto. intros [rs1 [P [Q R]]]. simpl in Q.
+ exploit loadind_correct. eexact EQ. instantiate (2 := rs1). rewrite Q. eauto.
+ intros [rs2 [S [T U]]].
+ exists rs2; split. eapply exec_straight_trans; eauto.
+ split. eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto.
+ simpl; intros. rewrite U; auto.
+
+- (* Mop *)
+ assert (eval_operation tge sp op rs##args m = Some v).
+ rewrite <- H. apply eval_operation_preserved. exact symbols_preserved.
+ exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. eexact H0.
+ intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A.
+ left; eapply exec_straight_steps; eauto; intros. simpl in TR.
+ exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]].
+ assert (S: Val.lessdef v (rs2 (preg_of res))) by (eapply Val.lessdef_trans; eauto).
+ exists rs2; split. eauto.
+ split. eapply agree_set_undef_mreg; eauto.
+ simpl; congruence.
+
+- (* Mload *)
+ assert (eval_addressing tge sp addr rs##args = Some a).
+ rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
+ exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1.
+ intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A.
+ exploit Mem.loadv_extends; eauto. intros [v' [C D]].
+ left; eapply exec_straight_steps; eauto; intros. simpl in TR.
+ exploit transl_load_correct; eauto. intros [rs2 [P [Q R]]].
+ exists rs2; split. eauto.
+ split. eapply agree_set_undef_mreg; eauto. congruence.
+ simpl; congruence.
+
+- (* Mstore *)
+ assert (eval_addressing tge sp addr rs##args = Some a).
+ rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
+ exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1.
+ intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A.
+ assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto.
+ exploit Mem.storev_extends; eauto. intros [m2' [C D]].
+ left; eapply exec_straight_steps; eauto.
+ intros. simpl in TR.
+ exploit transl_store_correct; eauto. intros [rs2 [P Q]].
+ exists rs2; split. eauto.
+ split. eapply agree_undef_regs; eauto.
+ simpl; congruence.
+
+- (* Mcall *)
+ assert (f0 = f) by congruence. subst f0.
+ inv AT.
+ assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned).
+ eapply transf_function_no_overflow; eauto.
+ destruct ros as [rf|fid]; simpl in H; monadInv H5.
++ (* Indirect call *)
+ assert (rs rf = Vptr f' Ptrofs.zero).
+ destruct (rs rf); try discriminate.
+ revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence.
+ assert (rs0 x0 = Vptr f' Ptrofs.zero).
+ exploit ireg_val; eauto. rewrite H5; intros LD; inv LD; auto.
+ generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1.
+ assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x).
+ econstructor; eauto.
+ exploit return_address_offset_correct; eauto. intros; subst ra.
+ left; econstructor; split.
+ apply plus_one. eapply exec_step_internal. eauto.
+ eapply functions_transl; eauto. eapply find_instr_tail; eauto.
+ simpl. eauto.
+ econstructor; eauto.
+ econstructor; eauto.
+ eapply agree_sp_def; eauto.
+ simpl. eapply agree_exten; eauto. intros. Simplifs.
+ Simplifs. rewrite <- H2. auto.
++ (* Direct call *)
+ generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1.
+ assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x).
+ econstructor; eauto.
+ exploit return_address_offset_correct; eauto. intros; subst ra.
+ left; econstructor; split.
+ apply plus_one. eapply exec_step_internal. eauto.
+ eapply functions_transl; eauto. eapply find_instr_tail; eauto.
+ simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. eauto.
+ econstructor; eauto.
+ econstructor; eauto.
+ eapply agree_sp_def; eauto.
+ simpl. eapply agree_exten; eauto. intros. Simplifs.
+ Simplifs. rewrite <- H2. auto.
+
+- (* Mtailcall *)
+ assert (f0 = f) by congruence. subst f0.
+ inv AT.
+ assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned).
+ eapply transf_function_no_overflow; eauto.
+ rewrite (sp_val _ _ _ AG) in *. unfold load_stack in *.
+ exploit Mem.loadv_extends. eauto. eexact H1. auto. simpl. intros [parent' [A B]].
+ exploit Mem.loadv_extends. eauto. eexact H2. auto. simpl. intros [ra' [C D]].
+ exploit lessdef_parent_sp; eauto. intros. subst parent'. clear B.
+ exploit lessdef_parent_ra; eauto. intros. subst ra'. clear D.
+ exploit Mem.free_parallel_extends; eauto. intros [m2' [E F]].
+ destruct ros as [rf|fid]; simpl in H; monadInv H7.
++ (* Indirect call *)
+ assert (rs rf = Vptr f' Ptrofs.zero).
+ destruct (rs rf); try discriminate.
+ revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence.
+ assert (rs0 x0 = Vptr f' Ptrofs.zero).
+ exploit ireg_val; eauto. rewrite H7; intros LD; inv LD; auto.
+ generalize (code_tail_next_int _ _ _ _ NOOV H8). intro CT1.
+ left; econstructor; split.
+ eapply plus_left. eapply exec_step_internal. eauto.
+ eapply functions_transl; eauto. eapply find_instr_tail; eauto.
+ simpl. replace (chunk_of_type Tptr) with Mptr in * by (unfold Tptr, Mptr; destruct Archi.ptr64; auto).
+ rewrite C. rewrite A. rewrite <- (sp_val _ _ _ AG). rewrite E. eauto.
+ apply star_one. eapply exec_step_internal.
+ transitivity (Val.offset_ptr rs0#PC Ptrofs.one). auto. rewrite <- H4. simpl. eauto.
+ eapply functions_transl; eauto. eapply find_instr_tail; eauto.
+ simpl. eauto. traceEq.
+ econstructor; eauto.
+ apply agree_set_other; auto. apply agree_nextinstr. apply agree_set_other; auto.
+ eapply agree_change_sp; eauto. eapply parent_sp_def; eauto.
+ Simplifs. rewrite Pregmap.gso; auto.
+ generalize (preg_of_not_SP rf). rewrite (ireg_of_eq _ _ EQ1). congruence.
++ (* Direct call *)
+ generalize (code_tail_next_int _ _ _ _ NOOV H8). intro CT1.
+ left; econstructor; split.
+ eapply plus_left. eapply exec_step_internal. eauto.
+ eapply functions_transl; eauto. eapply find_instr_tail; eauto.
+ simpl. replace (chunk_of_type Tptr) with Mptr in * by (unfold Tptr, Mptr; destruct Archi.ptr64; auto).
+ rewrite C. rewrite A. rewrite <- (sp_val _ _ _ AG). rewrite E. eauto.
+ apply star_one. eapply exec_step_internal.
+ transitivity (Val.offset_ptr rs0#PC Ptrofs.one). auto. rewrite <- H4. simpl. eauto.
+ eapply functions_transl; eauto. eapply find_instr_tail; eauto.
+ simpl. eauto. traceEq.
+ econstructor; eauto.
+ apply agree_set_other; auto. apply agree_nextinstr. apply agree_set_other; auto.
+ eapply agree_change_sp; eauto. eapply parent_sp_def; eauto.
+ rewrite Pregmap.gss. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. auto.
+
+- (* Mbuiltin *)
+ inv AT. monadInv H4.
+ exploit functions_transl; eauto. intro FN.
+ generalize (transf_function_no_overflow _ _ H3); intro NOOV.
+ exploit builtin_args_match; eauto. intros [vargs' [P Q]].
+ exploit external_call_mem_extends; eauto.
+ intros [vres' [m2' [A [B [C D]]]]].
+ left. econstructor; split. apply plus_one.
+ eapply exec_step_builtin. eauto. eauto.
+ eapply find_instr_tail; eauto.
+ erewrite <- sp_val by eauto.
+ eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved.
+ eapply external_call_symbols_preserved; eauto. apply senv_preserved.
+ eauto.
+ econstructor; eauto.
+ instantiate (2 := tf); instantiate (1 := x).
+ unfold nextinstr_nf, nextinstr. rewrite Pregmap.gss.
+ rewrite undef_regs_other. rewrite set_res_other. rewrite undef_regs_other_2.
+ rewrite <- H1. simpl. econstructor; eauto.
+ eapply code_tail_next_int; eauto.
+ rewrite preg_notin_charact. intros. auto with asmgen.
+ auto with asmgen.
+ simpl; intros. intuition congruence.
+ apply agree_nextinstr_nf. eapply agree_set_res; auto.
+ eapply agree_undef_regs; eauto. intros; apply undef_regs_other_2; auto.
+ congruence.
+
+- (* Mgoto *)
+ assert (f0 = f) by congruence. subst f0.
+ inv AT. monadInv H4.
+ exploit find_label_goto_label; eauto. intros [tc' [rs' [GOTO [AT2 INV]]]].
+ left; exists (State rs' m'); split.
+ apply plus_one. econstructor; eauto.
+ eapply functions_transl; eauto.
+ eapply find_instr_tail; eauto.
+ simpl; eauto.
+ econstructor; eauto.
+ eapply agree_exten; eauto with asmgen.
+ congruence.
+
+- (* Mcond true *)
+ assert (f0 = f) by congruence. subst f0.
+ exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC.
+ left; eapply exec_straight_steps_goto; eauto.
+ intros. simpl in TR.
+ destruct (transl_cond_correct tge tf cond args _ _ rs0 m' TR)
+ as [rs' [A [B C]]].
+ rewrite EC in B.
+ destruct (testcond_for_condition cond); simpl in *.
+(* simple jcc *)
+ exists (Pjcc c1 lbl); exists k; exists rs'.
+ split. eexact A.
+ split. eapply agree_exten; eauto.
+ simpl. rewrite B. auto.
+(* jcc; jcc *)
+ destruct (eval_testcond c1 rs') as [b1|] eqn:TC1;
+ destruct (eval_testcond c2 rs') as [b2|] eqn:TC2; inv B.
+ destruct b1.
+ (* first jcc jumps *)
+ exists (Pjcc c1 lbl); exists (Pjcc c2 lbl :: k); exists rs'.
+ split. eexact A.
+ split. eapply agree_exten; eauto.
+ simpl. rewrite TC1. auto.
+ (* second jcc jumps *)
+ exists (Pjcc c2 lbl); exists k; exists (nextinstr rs').
+ split. eapply exec_straight_trans. eexact A.
+ eapply exec_straight_one. simpl. rewrite TC1. auto. auto.
+ split. eapply agree_exten; eauto.
+ intros; Simplifs.
+ simpl. rewrite eval_testcond_nextinstr. rewrite TC2.
+ destruct b2; auto || discriminate.
+(* jcc2 *)
+ destruct (eval_testcond c1 rs') as [b1|] eqn:TC1;
+ destruct (eval_testcond c2 rs') as [b2|] eqn:TC2; inv B.
+ destruct (andb_prop _ _ H3). subst.
+ exists (Pjcc2 c1 c2 lbl); exists k; exists rs'.
+ split. eexact A.
+ split. eapply agree_exten; eauto.
+ simpl. rewrite TC1; rewrite TC2; auto.
+
+- (* Mcond false *)
+ exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC.
+ left; eapply exec_straight_steps; eauto. intros. simpl in TR.
+ destruct (transl_cond_correct tge tf cond args _ _ rs0 m' TR)
+ as [rs' [A [B C]]].
+ rewrite EC in B.
+ destruct (testcond_for_condition cond); simpl in *.
+(* simple jcc *)
+ econstructor; split.
+ eapply exec_straight_trans. eexact A.
+ apply exec_straight_one. simpl. rewrite B. eauto. auto.
+ split. apply agree_nextinstr. eapply agree_exten; eauto.
+ simpl; congruence.
+(* jcc ; jcc *)
+ destruct (eval_testcond c1 rs') as [b1|] eqn:TC1;
+ destruct (eval_testcond c2 rs') as [b2|] eqn:TC2; inv B.
+ destruct (orb_false_elim _ _ H1); subst.
+ econstructor; split.
+ eapply exec_straight_trans. eexact A.
+ eapply exec_straight_two. simpl. rewrite TC1. eauto. auto.
+ simpl. rewrite eval_testcond_nextinstr. rewrite TC2. eauto. auto. auto.
+ split. apply agree_nextinstr. apply agree_nextinstr. eapply agree_exten; eauto.
+ simpl; congruence.
+(* jcc2 *)
+ destruct (eval_testcond c1 rs') as [b1|] eqn:TC1;
+ destruct (eval_testcond c2 rs') as [b2|] eqn:TC2; inv B.
+ exists (nextinstr rs'); split.
+ eapply exec_straight_trans. eexact A.
+ apply exec_straight_one. simpl.
+ rewrite TC1; rewrite TC2.
+ destruct b1. simpl in *. subst b2. auto. auto.
+ auto.
+ split. apply agree_nextinstr. eapply agree_exten; eauto.
+ rewrite H1; congruence.
+
+- (* Mjumptable *)
+ assert (f0 = f) by congruence. subst f0.
+ inv AT. monadInv H6.
+ exploit functions_transl; eauto. intro FN.
+ generalize (transf_function_no_overflow _ _ H5); intro NOOV.
+ set (rs1 := rs0 #RAX <- Vundef #RDX <- Vundef).
+ exploit (find_label_goto_label f tf lbl rs1); eauto.
+ intros [tc' [rs' [A [B C]]]].
+ exploit ireg_val; eauto. rewrite H. intros LD; inv LD.
+ left; econstructor; split.
+ apply plus_one. econstructor; eauto.
+ eapply find_instr_tail; eauto.
+ simpl. rewrite <- H9. unfold Mach.label in H0; unfold label; rewrite H0. eexact A.
+ econstructor; eauto.
+Transparent destroyed_by_jumptable.
+ apply agree_undef_regs with rs0; auto.
+ simpl; intros. destruct H8. rewrite C by auto with asmgen. unfold rs1; Simplifs.
+ congruence.
+
+- (* Mreturn *)
+ assert (f0 = f) by congruence. subst f0.
+ inv AT.
+ assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned).
+ eapply transf_function_no_overflow; eauto.
+ rewrite (sp_val _ _ _ AG) in *. unfold load_stack in *.
+ replace (chunk_of_type Tptr) with Mptr in * by (unfold Tptr, Mptr; destruct Archi.ptr64; auto).
+ exploit Mem.loadv_extends. eauto. eexact H0. auto. simpl. intros [parent' [A B]].
+ exploit lessdef_parent_sp; eauto. intros. subst parent'. clear B.
+ exploit Mem.loadv_extends. eauto. eexact H1. auto. simpl. intros [ra' [C D]].
+ exploit lessdef_parent_ra; eauto. intros. subst ra'. clear D.
+ exploit Mem.free_parallel_extends; eauto. intros [m2' [E F]].
+ monadInv H6.
+ exploit code_tail_next_int; eauto. intro CT1.
+ left; econstructor; split.
+ eapply plus_left. eapply exec_step_internal. eauto.
+ eapply functions_transl; eauto. eapply find_instr_tail; eauto.
+ simpl. rewrite C. rewrite A. rewrite <- (sp_val _ _ _ AG). rewrite E. eauto.
+ apply star_one. eapply exec_step_internal.
+ transitivity (Val.offset_ptr rs0#PC Ptrofs.one). auto. rewrite <- H3. simpl. eauto.
+ eapply functions_transl; eauto. eapply find_instr_tail; eauto.
+ simpl. eauto. traceEq.
+ constructor; auto.
+ apply agree_set_other; auto. apply agree_nextinstr. apply agree_set_other; auto.
+ eapply agree_change_sp; eauto. eapply parent_sp_def; eauto.
+
+- (* internal function *)
+ exploit functions_translated; eauto. intros [tf [A B]]. monadInv B.
+ generalize EQ; intros EQ'. monadInv EQ'.
+ destruct (zlt Ptrofs.max_unsigned (list_length_z (fn_code x0))); inv EQ1.
+ monadInv EQ0. rewrite transl_code'_transl_code in EQ1.
+ unfold store_stack in *.
+ exploit Mem.alloc_extends. eauto. eauto. apply Zle_refl. apply Zle_refl.
+ intros [m1' [C D]].
+ exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto.
+ intros [m2' [F G]].
+ exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto.
+ intros [m3' [P Q]].
+ left; econstructor; split.
+ apply plus_one. econstructor; eauto.
+ simpl. rewrite Ptrofs.unsigned_zero. simpl. eauto.
+ simpl. rewrite C. simpl in F, P.
+ replace (chunk_of_type Tptr) with Mptr in F, P by (unfold Tptr, Mptr; destruct Archi.ptr64; auto).
+ rewrite (sp_val _ _ _ AG) in F. rewrite F.
+ rewrite ATLR. rewrite P. eauto.
+ econstructor; eauto.
+ unfold nextinstr. rewrite Pregmap.gss. repeat rewrite Pregmap.gso; auto with asmgen.
+ rewrite ATPC. simpl. constructor; eauto.
+ unfold fn_code. eapply code_tail_next_int. simpl in g. omega.
+ constructor.
+ apply agree_nextinstr. eapply agree_change_sp; eauto.
+Transparent destroyed_at_function_entry.
+ apply agree_undef_regs with rs0; eauto.
+ simpl; intros. apply Pregmap.gso; auto with asmgen. tauto.
+ congruence.
+ intros. Simplifs. eapply agree_sp; eauto.
+
+- (* external function *)
+ exploit functions_translated; eauto.
+ intros [tf [A B]]. simpl in B. inv B.
+ exploit extcall_arguments_match; eauto.
+ intros [args' [C D]].
+ exploit external_call_mem_extends; eauto.
+ intros [res' [m2' [P [Q [R S]]]]].
+ left; econstructor; split.
+ apply plus_one. eapply exec_step_external; eauto.
+ eapply external_call_symbols_preserved; eauto. apply senv_preserved.
+ econstructor; eauto.
+ unfold loc_external_result.
+ apply agree_set_other; auto. apply agree_set_pair; auto.
+
+- (* return *)
+ inv STACKS. simpl in *.
+ right. split. omega. split. auto.
+ econstructor; eauto. rewrite ATPC; eauto. congruence.
+Qed.
+
+Lemma transf_initial_states:
+ forall st1, Mach.initial_state prog st1 ->
+ exists st2, Asm.initial_state tprog st2 /\ match_states st1 st2.
+Proof.
+ intros. inversion H. unfold ge0 in *.
+ econstructor; split.
+ econstructor.
+ eapply (Genv.init_mem_transf_partial TRANSF); eauto.
+ replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero)
+ with (Vptr fb Ptrofs.zero).
+ econstructor; eauto.
+ constructor.
+ apply Mem.extends_refl.
+ split. reflexivity. simpl.
+ unfold Vnullptr; destruct Archi.ptr64; congruence.
+ intros. rewrite Regmap.gi. auto.
+ unfold Genv.symbol_address.
+ rewrite (match_program_main TRANSF).
+ rewrite symbols_preserved.
+ unfold ge; rewrite H1. auto.
+Qed.
+
+Lemma transf_final_states:
+ forall st1 st2 r,
+ match_states st1 st2 -> Mach.final_state st1 r -> Asm.final_state st2 r.
+Proof.
+ intros. inv H0. inv H. constructor. auto.
+ assert (r0 = AX).
+ { unfold loc_result in H1; destruct Archi.ptr64; compute in H1; congruence. }
+ subst r0.
+ generalize (preg_val _ _ _ AX AG). rewrite H2. intros LD; inv LD. auto.
+Qed.
+
+Theorem transf_program_correct:
+ forward_simulation (Mach.semantics return_address_offset prog) (Asm.semantics tprog).
+Proof.
+ eapply forward_simulation_star with (measure := measure).
+ apply senv_preserved.
+ eexact transf_initial_states.
+ eexact transf_final_states.
+ exact step_simulation.
+Qed.
+
+End PRESERVATION.
diff --git a/x86/Asmgenproof1.v b/x86/Asmgenproof1.v
new file mode 100644
index 00000000..401be7d7
--- /dev/null
+++ b/x86/Asmgenproof1.v
@@ -0,0 +1,1477 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris *)
+(* *)
+(* 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 x86-64 generation: auxiliary results. *)
+
+Require Import Coqlib.
+Require Import AST Errors Integers Floats Values Memory Globalenvs.
+Require Import Op Locations Conventions Mach Asm.
+Require Import Asmgen Asmgenproof0.
+
+Open Local Scope error_monad_scope.
+
+(** * Correspondence between Mach registers and x86 registers *)
+
+Lemma agree_nextinstr_nf:
+ forall ms sp rs,
+ agree ms sp rs -> agree ms sp (nextinstr_nf rs).
+Proof.
+ intros. unfold nextinstr_nf. apply agree_nextinstr.
+ apply agree_undef_nondata_regs. auto.
+ simpl; intros. intuition (subst r; auto).
+Qed.
+
+(** Useful properties of the PC register. *)
+
+Lemma nextinstr_nf_inv:
+ forall r rs,
+ match r with PC => False | CR _ => False | _ => True end ->
+ (nextinstr_nf rs)#r = rs#r.
+Proof.
+ intros. unfold nextinstr_nf. rewrite nextinstr_inv.
+ simpl. repeat rewrite Pregmap.gso; auto;
+ red; intro; subst; contradiction.
+ red; intro; subst; contradiction.
+Qed.
+
+Lemma nextinstr_nf_inv1:
+ forall r rs,
+ data_preg r = true -> (nextinstr_nf rs)#r = rs#r.
+Proof.
+ intros. apply nextinstr_nf_inv. destruct r; auto || discriminate.
+Qed.
+
+Lemma nextinstr_nf_set_preg:
+ forall rs m v,
+ (nextinstr_nf (rs#(preg_of m) <- v))#PC = Val.offset_ptr rs#PC Ptrofs.one.
+Proof.
+ intros. unfold nextinstr_nf.
+ transitivity (nextinstr (rs#(preg_of m) <- v) PC). auto.
+ apply nextinstr_set_preg.
+Qed.
+
+(** Useful simplification tactic *)
+
+Ltac Simplif :=
+ match goal with
+ | [ |- nextinstr_nf _ _ = _ ] =>
+ ((rewrite nextinstr_nf_inv by auto with asmgen)
+ || (rewrite nextinstr_nf_inv1 by auto with asmgen)); auto
+ | [ |- nextinstr _ _ = _ ] =>
+ ((rewrite nextinstr_inv by auto with asmgen)
+ || (rewrite nextinstr_inv1 by auto with asmgen)); auto
+ | [ |- Pregmap.get ?x (Pregmap.set ?x _ _) = _ ] =>
+ rewrite Pregmap.gss; auto
+ | [ |- Pregmap.set ?x _ _ ?x = _ ] =>
+ rewrite Pregmap.gss; auto
+ | [ |- Pregmap.get _ (Pregmap.set _ _ _) = _ ] =>
+ rewrite Pregmap.gso by (auto with asmgen); auto
+ | [ |- Pregmap.set _ _ _ _ = _ ] =>
+ rewrite Pregmap.gso by (auto with asmgen); auto
+ end.
+
+Ltac Simplifs := repeat Simplif.
+
+(** * Correctness of x86-64 constructor functions *)
+
+Section CONSTRUCTORS.
+
+Variable ge: genv.
+Variable fn: function.
+
+(** Smart constructor for moves. *)
+
+Lemma mk_mov_correct:
+ forall rd rs k c rs1 m,
+ mk_mov rd rs k = OK c ->
+ exists rs2,
+ exec_straight ge fn c rs1 m k rs2 m
+ /\ rs2#rd = rs1#rs
+ /\ forall r, data_preg r = true -> r <> rd -> rs2#r = rs1#r.
+Proof.
+ unfold mk_mov; intros.
+ destruct rd; try (monadInv H); destruct rs; monadInv H.
+(* mov *)
+ econstructor. split. apply exec_straight_one. simpl. eauto. auto.
+ split. Simplifs. intros; Simplifs.
+(* movsd *)
+ econstructor. split. apply exec_straight_one. simpl. eauto. auto.
+ split. Simplifs. intros; Simplifs.
+Qed.
+
+(** Properties of division *)
+
+Lemma divu_modu_exists:
+ forall v1 v2,
+ Val.divu v1 v2 <> None \/ Val.modu v1 v2 <> None ->
+ exists n d q r,
+ v1 = Vint n /\ v2 = Vint d
+ /\ Int.divmodu2 Int.zero n d = Some(q, r)
+ /\ Val.divu v1 v2 = Some (Vint q) /\ Val.modu v1 v2 = Some (Vint r).
+Proof.
+ intros v1 v2; unfold Val.divu, Val.modu.
+ destruct v1; try (intuition discriminate).
+ destruct v2; try (intuition discriminate).
+ predSpec Int.eq Int.eq_spec i0 Int.zero ; try (intuition discriminate).
+ intros _. exists i, i0, (Int.divu i i0), (Int.modu i i0); intuition auto.
+ apply Int.divmodu2_divu_modu; auto.
+Qed.
+
+Lemma divs_mods_exists:
+ forall v1 v2,
+ Val.divs v1 v2 <> None \/ Val.mods v1 v2 <> None ->
+ exists nh nl d q r,
+ Val.shr v1 (Vint (Int.repr 31)) = Vint nh /\ v1 = Vint nl /\ v2 = Vint d
+ /\ Int.divmods2 nh nl d = Some(q, r)
+ /\ Val.divs v1 v2 = Some (Vint q) /\ Val.mods v1 v2 = Some (Vint r).
+Proof.
+ intros v1 v2; unfold Val.divs, Val.mods.
+ destruct v1; try (intuition discriminate).
+ destruct v2; try (intuition discriminate).
+ destruct (Int.eq i0 Int.zero
+ || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone) eqn:OK;
+ try (intuition discriminate).
+ intros _.
+ InvBooleans.
+ exists (Int.shr i (Int.repr 31)), i, i0, (Int.divs i i0), (Int.mods i i0); intuition auto.
+ rewrite Int.shr_lt_zero. apply Int.divmods2_divs_mods.
+ red; intros; subst i0; rewrite Int.eq_true in H; discriminate.
+ revert H0. predSpec Int.eq Int.eq_spec i (Int.repr Int.min_signed); auto.
+ predSpec Int.eq Int.eq_spec i0 Int.mone; auto.
+ discriminate.
+Qed.
+
+Lemma divlu_modlu_exists:
+ forall v1 v2,
+ Val.divlu v1 v2 <> None \/ Val.modlu v1 v2 <> None ->
+ exists n d q r,
+ v1 = Vlong n /\ v2 = Vlong d
+ /\ Int64.divmodu2 Int64.zero n d = Some(q, r)
+ /\ Val.divlu v1 v2 = Some (Vlong q) /\ Val.modlu v1 v2 = Some (Vlong r).
+Proof.
+ intros v1 v2; unfold Val.divlu, Val.modlu.
+ destruct v1; try (intuition discriminate).
+ destruct v2; try (intuition discriminate).
+ predSpec Int64.eq Int64.eq_spec i0 Int64.zero ; try (intuition discriminate).
+ intros _. exists i, i0, (Int64.divu i i0), (Int64.modu i i0); intuition auto.
+ apply Int64.divmodu2_divu_modu; auto.
+Qed.
+
+Lemma divls_modls_exists:
+ forall v1 v2,
+ Val.divls v1 v2 <> None \/ Val.modls v1 v2 <> None ->
+ exists nh nl d q r,
+ Val.shrl v1 (Vint (Int.repr 63)) = Vlong nh /\ v1 = Vlong nl /\ v2 = Vlong d
+ /\ Int64.divmods2 nh nl d = Some(q, r)
+ /\ Val.divls v1 v2 = Some (Vlong q) /\ Val.modls v1 v2 = Some (Vlong r).
+Proof.
+ intros v1 v2; unfold Val.divls, Val.modls.
+ destruct v1; try (intuition discriminate).
+ destruct v2; try (intuition discriminate).
+ destruct (Int64.eq i0 Int64.zero
+ || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone) eqn:OK;
+ try (intuition discriminate).
+ intros _.
+ InvBooleans.
+ exists (Int64.shr i (Int64.repr 63)), i, i0, (Int64.divs i i0), (Int64.mods i i0); intuition auto.
+ rewrite Int64.shr_lt_zero. apply Int64.divmods2_divs_mods.
+ red; intros; subst i0; rewrite Int64.eq_true in H; discriminate.
+ revert H0. predSpec Int64.eq Int64.eq_spec i (Int64.repr Int64.min_signed); auto.
+ predSpec Int64.eq Int64.eq_spec i0 Int64.mone; auto.
+ discriminate.
+Qed.
+
+(** Smart constructor for [shrx] *)
+
+Lemma mk_shrximm_correct:
+ forall n k c (rs1: regset) v m,
+ mk_shrximm n k = OK c ->
+ Val.shrx (rs1#RAX) (Vint n) = Some v ->
+ exists rs2,
+ exec_straight ge fn c rs1 m k rs2 m
+ /\ rs2#RAX = v
+ /\ forall r, data_preg r = true -> r <> RAX -> r <> RCX -> rs2#r = rs1#r.
+Proof.
+ unfold mk_shrximm; intros. inv H.
+ exploit Val.shrx_shr; eauto. intros [x [y [A [B C]]]].
+ inversion B; clear B; subst y; subst v; clear H0.
+ set (tnm1 := Int.sub (Int.shl Int.one n) Int.one).
+ set (x' := Int.add x tnm1).
+ set (rs2 := nextinstr (compare_ints (Vint x) (Vint Int.zero) rs1 m)).
+ set (rs3 := nextinstr (rs2#RCX <- (Vint x'))).
+ set (rs4 := nextinstr (if Int.lt x Int.zero then rs3#RAX <- (Vint x') else rs3)).
+ set (rs5 := nextinstr_nf (rs4#RAX <- (Val.shr rs4#RAX (Vint n)))).
+ assert (rs3#RAX = Vint x). unfold rs3. Simplifs.
+ assert (rs3#RCX = Vint x'). unfold rs3. Simplifs.
+ exists rs5. split.
+ apply exec_straight_step with rs2 m. simpl. rewrite A. simpl. rewrite Int.and_idem. auto. auto.
+ apply exec_straight_step with rs3 m. simpl.
+ change (rs2 RAX) with (rs1 RAX). rewrite A. simpl.
+ rewrite Int.repr_unsigned. rewrite Int.add_zero_l. auto. auto.
+ apply exec_straight_step with rs4 m. simpl.
+ rewrite Int.lt_sub_overflow. unfold rs4. destruct (Int.lt x Int.zero); simpl; auto.
+ unfold rs4. destruct (Int.lt x Int.zero); simpl; auto.
+ apply exec_straight_one. auto. auto.
+ split. unfold rs5. Simplifs. unfold rs4. rewrite nextinstr_inv; auto with asmgen.
+ destruct (Int.lt x Int.zero). rewrite Pregmap.gss. rewrite A; auto. rewrite A; rewrite H; auto.
+ intros. unfold rs5. Simplifs. unfold rs4. Simplifs.
+ transitivity (rs3#r). destruct (Int.lt x Int.zero). Simplifs. auto.
+ unfold rs3. Simplifs. unfold rs2. Simplifs.
+ unfold compare_ints. Simplifs.
+Qed.
+
+(** Smart constructor for [shrxl] *)
+
+Lemma mk_shrxlimm_correct:
+ forall n k c (rs1: regset) v m,
+ mk_shrxlimm n k = OK c ->
+ Val.shrxl (rs1#RAX) (Vint n) = Some v ->
+ exists rs2,
+ exec_straight ge fn c rs1 m k rs2 m
+ /\ rs2#RAX = v
+ /\ forall r, data_preg r = true -> r <> RAX -> r <> RDX -> rs2#r = rs1#r.
+Proof.
+ unfold mk_shrxlimm; intros. exploit Val.shrxl_shrl_2; eauto. intros EQ.
+ destruct (Int.eq n Int.zero); inv H.
+- econstructor; split. apply exec_straight_one. simpl; reflexivity. auto.
+ split. Simplifs. intros; Simplifs.
+- set (v1 := Val.shrl (rs1 RAX) (Vint (Int.repr 63))) in *.
+ set (v2 := Val.shrlu v1 (Vint (Int.sub (Int.repr 64) n))) in *.
+ set (v3 := Val.addl (rs1 RAX) v2) in *.
+ set (v4 := Val.shrl v3 (Vint n)) in *.
+ set (rs2 := nextinstr_nf (rs1#RDX <- v1)).
+ set (rs3 := nextinstr_nf (rs2#RDX <- v2)).
+ set (rs4 := nextinstr (rs3#RAX <- v3)).
+ set (rs5 := nextinstr_nf (rs4#RAX <- v4)).
+ assert (X: forall v1 v2,
+ Val.addl v1 (Val.addl v2 (Vlong Int64.zero)) = Val.addl v1 v2).
+ { intros. unfold Val.addl; destruct Archi.ptr64 eqn:SF, v0; auto; destruct v5; auto.
+ rewrite Int64.add_zero; auto.
+ rewrite Ptrofs.add_zero; auto.
+ rewrite Int64.add_zero; auto.
+ rewrite Int64.add_zero; auto. }
+ exists rs5; split.
+ eapply exec_straight_trans with (rs2 := rs3).
+ eapply exec_straight_two with (rs2 := rs2); reflexivity.
+ eapply exec_straight_two with (rs2 := rs4).
+ simpl. rewrite X. reflexivity. reflexivity. reflexivity. reflexivity.
+ split. unfold rs5; Simplifs.
+ intros. unfold rs5; Simplifs. unfold rs4; Simplifs. unfold rs3; Simplifs. unfold rs2; Simplifs.
+Qed.
+
+(** Smart constructor for integer conversions *)
+
+Lemma mk_intconv_correct:
+ forall mk sem rd rs k c rs1 m,
+ mk_intconv mk rd rs k = OK c ->
+ (forall c rd rs r m,
+ exec_instr ge c (mk rd rs) r m = Next (nextinstr (r#rd <- (sem r#rs))) m) ->
+ exists rs2,
+ exec_straight ge fn c rs1 m k rs2 m
+ /\ rs2#rd = sem rs1#rs
+ /\ forall r, data_preg r = true -> r <> rd -> r <> RAX -> rs2#r = rs1#r.
+Proof.
+ unfold mk_intconv; intros. destruct (Archi.ptr64 || low_ireg rs); monadInv H.
+ econstructor. split. apply exec_straight_one. rewrite H0. eauto. auto.
+ split. Simplifs. intros. Simplifs.
+ econstructor. split. eapply exec_straight_two.
+ simpl. eauto. apply H0. auto. auto.
+ split. Simplifs. intros. Simplifs.
+Qed.
+
+(** Smart constructor for small stores *)
+
+Lemma addressing_mentions_correct:
+ forall a r (rs1 rs2: regset),
+ (forall (r': ireg), r' <> r -> rs1 r' = rs2 r') ->
+ addressing_mentions a r = false ->
+ eval_addrmode32 ge a rs1 = eval_addrmode32 ge a rs2.
+Proof.
+ intros until rs2; intro AG. unfold addressing_mentions, eval_addrmode32.
+ destruct a. intros. destruct (orb_false_elim _ _ H). unfold proj_sumbool in *.
+ decEq. destruct base; auto. apply AG. destruct (ireg_eq r i); congruence.
+ decEq. destruct ofs as [[r' sc] | ]; auto. rewrite AG; auto. destruct (ireg_eq r r'); congruence.
+Qed.
+
+Lemma mk_storebyte_correct:
+ forall addr r k c rs1 m1 m2,
+ mk_storebyte addr r k = OK c ->
+ Mem.storev Mint8unsigned m1 (eval_addrmode ge addr rs1) (rs1 r) = Some m2 ->
+ exists rs2,
+ exec_straight ge fn c rs1 m1 k rs2 m2
+ /\ forall r, data_preg r = true -> preg_notin r (if Archi.ptr64 then nil else AX :: CX :: nil) -> rs2#r = rs1#r.
+Proof.
+ unfold mk_storebyte; intros.
+ destruct (Archi.ptr64 || low_ireg r) eqn:E.
+(* low reg *)
+ monadInv H. econstructor; split. apply exec_straight_one.
+ simpl. unfold exec_store. rewrite H0. eauto. auto.
+ intros; Simplifs.
+(* high reg *)
+ InvBooleans. rewrite H1; simpl. destruct (addressing_mentions addr RAX) eqn:E; monadInv H.
+(* RAX is mentioned. *)
+ assert (r <> RCX). { red; intros; subst r; discriminate H2. }
+ set (rs2 := nextinstr (rs1#RCX <- (eval_addrmode32 ge addr rs1))).
+ set (rs3 := nextinstr (rs2#RAX <- (rs1 r))).
+ econstructor; split.
+ apply exec_straight_three with rs2 m1 rs3 m1.
+ simpl. auto.
+ simpl. replace (rs2 r) with (rs1 r). auto. symmetry. unfold rs2; Simplifs.
+ simpl. unfold exec_store. unfold eval_addrmode; rewrite H1; simpl. rewrite Int.add_zero.
+ change (rs3 RAX) with (rs1 r).
+ change (rs3 RCX) with (eval_addrmode32 ge addr rs1).
+ replace (Val.add (eval_addrmode32 ge addr rs1) (Vint Int.zero))
+ with (eval_addrmode ge addr rs1).
+ rewrite H0. eauto.
+ unfold eval_addrmode in *; rewrite H1 in *.
+ destruct (eval_addrmode32 ge addr rs1); simpl in H0; try discriminate H0.
+ simpl. rewrite H1. rewrite Ptrofs.add_zero; auto.
+ auto. auto. auto.
+ intros. destruct H4. Simplifs. unfold rs3; Simplifs. unfold rs2; Simplifs.
+(* RAX is not mentioned *)
+ set (rs2 := nextinstr (rs1#RAX <- (rs1 r))).
+ econstructor; split.
+ apply exec_straight_two with rs2 m1.
+ simpl. auto.
+ simpl. unfold exec_store. unfold eval_addrmode in *; rewrite H1 in *.
+ rewrite (addressing_mentions_correct addr RAX rs2 rs1); auto.
+ change (rs2 RAX) with (rs1 r). rewrite H0. eauto.
+ intros. unfold rs2; Simplifs.
+ auto. auto.
+ intros. destruct H3. simpl. Simplifs. unfold rs2; Simplifs.
+Qed.
+
+(** Accessing slots in the stack frame *)
+
+Remark eval_addrmode_indexed:
+ forall (base: ireg) ofs (rs: regset),
+ match rs#base with Vptr _ _ => True | _ => False end ->
+ eval_addrmode ge (Addrmode (Some base) None (inl _ (Ptrofs.unsigned ofs))) rs = Val.offset_ptr rs#base ofs.
+Proof.
+ intros. destruct (rs#base) eqn:BASE; try contradiction.
+ intros; unfold eval_addrmode; destruct Archi.ptr64 eqn:SF; simpl; rewrite BASE; simpl; rewrite SF; simpl.
+- apply f_equal. apply f_equal. rewrite Int64.add_zero_l. rewrite <- (Ptrofs.repr_unsigned ofs) at 2. auto with ptrofs.
+- apply f_equal. apply f_equal. rewrite Int.add_zero_l. rewrite <- (Ptrofs.repr_unsigned ofs) at 2. auto with ptrofs.
+Qed.
+
+Ltac loadind_correct_solve :=
+ match goal with
+ | H: Error _ = OK _ |- _ => discriminate H
+ | H: OK _ = OK _ |- _ => inv H
+ | H: match ?x with _ => _ end = OK _ |- _ => destruct x eqn:?; loadind_correct_solve
+ | _ => idtac
+ end.
+
+Lemma loadind_correct:
+ forall (base: ireg) ofs ty dst k (rs: regset) c m v,
+ loadind base ofs ty dst k = OK c ->
+ Mem.loadv (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) = Some v ->
+ exists rs',
+ exec_straight ge fn c rs m k rs' m
+ /\ rs'#(preg_of dst) = v
+ /\ forall r, data_preg r = true -> r <> preg_of dst -> rs'#r = rs#r.
+Proof.
+ unfold loadind; intros.
+ set (addr := Addrmode (Some base) None (inl (ident * ptrofs) (Ptrofs.unsigned ofs))) in *.
+ assert (eval_addrmode ge addr rs = Val.offset_ptr rs#base ofs).
+ { apply eval_addrmode_indexed. destruct (rs base); auto || discriminate. }
+ rewrite <- H1 in H0.
+ exists (nextinstr_nf (rs#(preg_of dst) <- v)); split.
+- loadind_correct_solve; apply exec_straight_one; auto; simpl in *; unfold exec_load; rewrite ?Heqb, ?H0; auto.
+- intuition Simplifs.
+Qed.
+
+Lemma storeind_correct:
+ forall (base: ireg) ofs ty src k (rs: regset) c m m',
+ storeind src base ofs ty k = OK c ->
+ Mem.storev (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) (rs#(preg_of src)) = Some m' ->
+ exists rs',
+ exec_straight ge fn c rs m k rs' m'
+ /\ forall r, data_preg r = true -> preg_notin r (destroyed_by_setstack ty) -> rs'#r = rs#r.
+Proof.
+ unfold storeind; intros.
+ set (addr := Addrmode (Some base) None (inl (ident * ptrofs) (Ptrofs.unsigned ofs))) in *.
+ assert (eval_addrmode ge addr rs = Val.offset_ptr rs#base ofs).
+ { apply eval_addrmode_indexed. destruct (rs base); auto || discriminate. }
+ rewrite <- H1 in H0.
+ loadind_correct_solve; simpl in H0;
+ (econstructor; split;
+ [apply exec_straight_one; [simpl; unfold exec_store; rewrite ?Heqb, H0;eauto|auto]
+ |simpl; intros; unfold undef_regs; repeat Simplifs]).
+Qed.
+
+(** Translation of addressing modes *)
+
+Lemma transl_addressing_mode_32_correct:
+ forall addr args am (rs: regset) v,
+ transl_addressing addr args = OK am ->
+ eval_addressing32 ge (rs RSP) addr (List.map rs (List.map preg_of args)) = Some v ->
+ Val.lessdef v (eval_addrmode32 ge am rs).
+Proof.
+ assert (A: forall id ofs, Archi.ptr64 = false ->
+ Val.add (Vint Int.zero) (Genv.symbol_address ge id ofs) = Genv.symbol_address ge id ofs).
+ { intros. unfold Val.add; rewrite H. unfold Genv.symbol_address.
+ destruct (Genv.find_symbol ge id); auto. rewrite Ptrofs.add_zero; auto. }
+ assert (C: forall v i,
+ Val.lessdef (Val.mul v (Vint (Int.repr i)))
+ (if zeq i 1 then v else Val.mul v (Vint (Int.repr i)))).
+ { intros. destruct (zeq i 1); subst; auto.
+ destruct v; simpl; auto. rewrite Int.mul_one; auto. }
+ unfold transl_addressing; intros.
+ destruct addr; repeat (destruct args; try discriminate H); simpl in H0; FuncInv;
+ monadInv H; try (erewrite ! ireg_of_eq by eauto); unfold eval_addrmode32.
+- simpl; rewrite Int.add_zero_l; auto.
+- rewrite Val.add_assoc. apply Val.add_lessdef; auto.
+- rewrite Val.add_permut. apply Val.add_lessdef; auto. simpl; rewrite Int.add_zero_l; auto.
+- apply Val.add_lessdef; auto. apply Val.add_lessdef; auto.
+- rewrite ! A by auto. auto.
+- rewrite Val.add_commut. rewrite A by auto. auto.
+- rewrite Val.add_permut. rewrite Val.add_commut. apply Val.add_lessdef; auto. rewrite A; auto.
+- simpl. unfold Val.add; rewrite Heqb.
+ destruct (rs RSP); simpl; auto.
+ rewrite Int.add_zero_l. apply Val.lessdef_same; f_equal; f_equal.
+ symmetry. transitivity (Ptrofs.repr (Ptrofs.signed i)). auto with ptrofs. auto with ints.
+Qed.
+
+Lemma transl_addressing_mode_64_correct:
+ forall addr args am (rs: regset) v,
+ transl_addressing addr args = OK am ->
+ eval_addressing64 ge (rs RSP) addr (List.map rs (List.map preg_of args)) = Some v ->
+ Val.lessdef v (eval_addrmode64 ge am rs).
+Proof.
+ assert (A: forall id ofs, Archi.ptr64 = true ->
+ Val.addl (Vlong Int64.zero) (Genv.symbol_address ge id ofs) = Genv.symbol_address ge id ofs).
+ { intros. unfold Val.addl; rewrite H. unfold Genv.symbol_address.
+ destruct (Genv.find_symbol ge id); auto. rewrite Ptrofs.add_zero; auto. }
+ assert (C: forall v i,
+ Val.lessdef (Val.mull v (Vlong (Int64.repr i)))
+ (if zeq i 1 then v else Val.mull v (Vlong (Int64.repr i)))).
+ { intros. destruct (zeq i 1); subst; auto.
+ destruct v; simpl; auto. rewrite Int64.mul_one; auto. }
+ unfold transl_addressing; intros.
+ destruct addr; repeat (destruct args; try discriminate H); simpl in H0; FuncInv;
+ monadInv H; try (erewrite ! ireg_of_eq by eauto); unfold eval_addrmode64.
+- simpl; rewrite Int64.add_zero_l; auto.
+- rewrite Val.addl_assoc. apply Val.addl_lessdef; auto.
+- rewrite Val.addl_permut. apply Val.addl_lessdef; auto. simpl; rewrite Int64.add_zero_l; auto.
+- apply Val.addl_lessdef; auto. apply Val.addl_lessdef; auto.
+- rewrite ! A by auto. auto.
+- unfold Val.addl; rewrite Heqb. destruct (rs RSP); auto. simpl.
+ rewrite Int64.add_zero_l. apply Val.lessdef_same; f_equal; f_equal.
+ symmetry. transitivity (Ptrofs.repr (Ptrofs.signed i)). auto with ptrofs. auto with ints.
+Qed.
+
+Lemma transl_addressing_mode_correct:
+ forall addr args am (rs: regset) v,
+ transl_addressing addr args = OK am ->
+ eval_addressing ge (rs RSP) addr (List.map rs (List.map preg_of args)) = Some v ->
+ Val.lessdef v (eval_addrmode ge am rs).
+Proof.
+ unfold eval_addressing, eval_addrmode; intros. destruct Archi.ptr64.
+ eapply transl_addressing_mode_64_correct; eauto.
+ eapply transl_addressing_mode_32_correct; eauto.
+Qed.
+
+Lemma normalize_addrmode_32_correct:
+ forall am rs, eval_addrmode32 ge (normalize_addrmode_32 am) rs = eval_addrmode32 ge am rs.
+Proof.
+ intros; destruct am as [base ofs [n|r]]; simpl; auto. rewrite Int.repr_signed. auto.
+Qed.
+
+Lemma normalize_addrmode_64_correct:
+ forall am rs,
+ eval_addrmode64 ge am rs =
+ match normalize_addrmode_64 am with
+ | (am', None) => eval_addrmode64 ge am' rs
+ | (am', Some delta) => Val.addl (eval_addrmode64 ge am' rs) (Vlong delta)
+ end.
+Proof.
+ intros; destruct am as [base ofs [n|r]]; simpl; auto.
+ destruct (zeq (Int.signed (Int.repr n)) n); simpl; auto.
+ rewrite ! Val.addl_assoc. apply f_equal. apply f_equal. simpl. rewrite Int64.add_zero_l; auto.
+Qed.
+
+(** Processor conditions and comparisons *)
+
+Lemma compare_ints_spec:
+ forall rs v1 v2 m,
+ let rs' := nextinstr (compare_ints v1 v2 rs m) in
+ rs'#ZF = Val.cmpu (Mem.valid_pointer m) Ceq v1 v2
+ /\ rs'#CF = Val.cmpu (Mem.valid_pointer m) Clt v1 v2
+ /\ rs'#SF = Val.negative (Val.sub v1 v2)
+ /\ rs'#OF = Val.sub_overflow v1 v2
+ /\ (forall r, data_preg r = true -> rs'#r = rs#r).
+Proof.
+ intros. unfold rs'; unfold compare_ints.
+ split. auto.
+ split. auto.
+ split. auto.
+ split. auto.
+ intros. Simplifs.
+Qed.
+
+Lemma testcond_for_signed_comparison_32_correct:
+ forall c v1 v2 rs m b,
+ Val.cmp_bool c v1 v2 = Some b ->
+ eval_testcond (testcond_for_signed_comparison c)
+ (nextinstr (compare_ints v1 v2 rs m)) = Some b.
+Proof.
+ intros. generalize (compare_ints_spec rs v1 v2 m).
+ set (rs' := nextinstr (compare_ints v1 v2 rs m)).
+ intros [A [B [C [D E]]]].
+ destruct v1; destruct v2; simpl in H; inv H.
+ unfold eval_testcond. rewrite A; rewrite B; rewrite C; rewrite D.
+ simpl. unfold Val.cmp, Val.cmpu.
+ rewrite Int.lt_sub_overflow.
+ destruct c; simpl.
+ destruct (Int.eq i i0); auto.
+ destruct (Int.eq i i0); auto.
+ destruct (Int.lt i i0); auto.
+ rewrite Int.not_lt. destruct (Int.lt i i0); simpl; destruct (Int.eq i i0); auto.
+ rewrite (Int.lt_not i i0). destruct (Int.lt i i0); destruct (Int.eq i i0); reflexivity.
+ destruct (Int.lt i i0); reflexivity.
+Qed.
+
+Lemma testcond_for_unsigned_comparison_32_correct:
+ forall c v1 v2 rs m b,
+ Val.cmpu_bool (Mem.valid_pointer m) c v1 v2 = Some b ->
+ eval_testcond (testcond_for_unsigned_comparison c)
+ (nextinstr (compare_ints v1 v2 rs m)) = Some b.
+Proof.
+ intros. generalize (compare_ints_spec rs v1 v2 m).
+ set (rs' := nextinstr (compare_ints v1 v2 rs m)).
+ intros [A [B [C [D E]]]].
+ unfold eval_testcond. rewrite A; rewrite B. unfold Val.cmpu, Val.cmp.
+ destruct v1; destruct v2; simpl in H; FuncInv; subst.
+- (* int int *)
+ destruct c; simpl; auto.
+ destruct (Int.eq i i0); reflexivity.
+ destruct (Int.eq i i0); auto.
+ destruct (Int.ltu i i0); auto.
+ rewrite Int.not_ltu. destruct (Int.ltu i i0); simpl; destruct (Int.eq i i0); auto.
+ rewrite (Int.ltu_not i i0). destruct (Int.ltu i i0); destruct (Int.eq i i0); reflexivity.
+ destruct (Int.ltu i i0); reflexivity.
+- (* int ptr *)
+ unfold Val.cmpu_bool; rewrite Heqb1.
+ destruct (Int.eq i Int.zero &&
+ (Mem.valid_pointer m b0 (Ptrofs.unsigned i0) || Mem.valid_pointer m b0 (Ptrofs.unsigned i0 - 1))); try discriminate H.
+ destruct c; simpl in *; inv H; reflexivity.
+- (* ptr int *)
+ unfold Val.cmpu_bool; rewrite Heqb1.
+ destruct (Int.eq i0 Int.zero &&
+ (Mem.valid_pointer m b0 (Ptrofs.unsigned i) || Mem.valid_pointer m b0 (Ptrofs.unsigned i - 1))); try discriminate H.
+ destruct c; simpl in *; inv H; reflexivity.
+- (* ptr ptr *)
+ unfold Val.cmpu_bool; rewrite Heqb2.
+ fold (Mem.weak_valid_pointer m b0 (Ptrofs.unsigned i)) in *.
+ fold (Mem.weak_valid_pointer m b1 (Ptrofs.unsigned i0)) in *.
+ destruct (eq_block b0 b1).
+ destruct (Mem.weak_valid_pointer m b0 (Ptrofs.unsigned i) &&
+ Mem.weak_valid_pointer m b1 (Ptrofs.unsigned i0)); inv H.
+ destruct c; simpl; auto.
+ destruct (Ptrofs.eq i i0); auto.
+ destruct (Ptrofs.eq i i0); auto.
+ destruct (Ptrofs.ltu i i0); auto.
+ rewrite Ptrofs.not_ltu. destruct (Ptrofs.ltu i i0); simpl; destruct (Ptrofs.eq i i0); auto.
+ rewrite (Ptrofs.ltu_not i i0). destruct (Ptrofs.ltu i i0); destruct (Ptrofs.eq i i0); reflexivity.
+ destruct (Ptrofs.ltu i i0); reflexivity.
+ destruct (Mem.valid_pointer m b0 (Ptrofs.unsigned i) &&
+ Mem.valid_pointer m b1 (Ptrofs.unsigned i0)); try discriminate H.
+ destruct c; simpl in *; inv H; reflexivity.
+Qed.
+
+Lemma compare_longs_spec:
+ forall rs v1 v2 m,
+ let rs' := nextinstr (compare_longs v1 v2 rs m) in
+ rs'#ZF = Val.maketotal (Val.cmplu (Mem.valid_pointer m) Ceq v1 v2)
+ /\ rs'#CF = Val.maketotal (Val.cmplu (Mem.valid_pointer m) Clt v1 v2)
+ /\ rs'#SF = Val.negativel (Val.subl v1 v2)
+ /\ rs'#OF = Val.subl_overflow v1 v2
+ /\ (forall r, data_preg r = true -> rs'#r = rs#r).
+Proof.
+ intros. unfold rs'; unfold compare_longs.
+ split. auto.
+ split. auto.
+ split. auto.
+ split. auto.
+ intros. Simplifs.
+Qed.
+
+Lemma int64_sub_overflow:
+ forall x y,
+ Int.xor (Int.repr (Int64.unsigned (Int64.sub_overflow x y Int64.zero)))
+ (Int.repr (Int64.unsigned (Int64.negative (Int64.sub x y)))) =
+ (if Int64.lt x y then Int.one else Int.zero).
+Proof.
+ intros.
+ transitivity (Int.repr (Int64.unsigned (if Int64.lt x y then Int64.one else Int64.zero))).
+ rewrite <- (Int64.lt_sub_overflow x y).
+ unfold Int64.sub_overflow, Int64.negative.
+ set (s := Int64.signed x - Int64.signed y - Int64.signed Int64.zero).
+ destruct (zle Int64.min_signed s && zle s Int64.max_signed);
+ destruct (Int64.lt (Int64.sub x y) Int64.zero);
+ auto.
+ destruct (Int64.lt x y); auto.
+Qed.
+
+Lemma testcond_for_signed_comparison_64_correct:
+ forall c v1 v2 rs m b,
+ Val.cmpl_bool c v1 v2 = Some b ->
+ eval_testcond (testcond_for_signed_comparison c)
+ (nextinstr (compare_longs v1 v2 rs m)) = Some b.
+Proof.
+ intros. generalize (compare_longs_spec rs v1 v2 m).
+ set (rs' := nextinstr (compare_longs v1 v2 rs m)).
+ intros [A [B [C [D E]]]].
+ destruct v1; destruct v2; simpl in H; inv H.
+ unfold eval_testcond. rewrite A; rewrite B; rewrite C; rewrite D.
+ simpl; rewrite int64_sub_overflow.
+ destruct c; simpl.
+ destruct (Int64.eq i i0); auto.
+ destruct (Int64.eq i i0); auto.
+ destruct (Int64.lt i i0); auto.
+ rewrite Int64.not_lt. destruct (Int64.lt i i0); simpl; destruct (Int64.eq i i0); auto.
+ rewrite (Int64.lt_not i i0). destruct (Int64.lt i i0); destruct (Int64.eq i i0); reflexivity.
+ destruct (Int64.lt i i0); reflexivity.
+Qed.
+
+Lemma testcond_for_unsigned_comparison_64_correct:
+ forall c v1 v2 rs m b,
+ Val.cmplu_bool (Mem.valid_pointer m) c v1 v2 = Some b ->
+ eval_testcond (testcond_for_unsigned_comparison c)
+ (nextinstr (compare_longs v1 v2 rs m)) = Some b.
+Proof.
+ intros. generalize (compare_longs_spec rs v1 v2 m).
+ set (rs' := nextinstr (compare_longs v1 v2 rs m)).
+ intros [A [B [C [D E]]]].
+ unfold eval_testcond. rewrite A; rewrite B.
+ destruct v1; destruct v2; simpl in H; FuncInv; subst.
+- (* int int *)
+ destruct c; simpl; auto.
+ destruct (Int64.eq i i0); reflexivity.
+ destruct (Int64.eq i i0); auto.
+ destruct (Int64.ltu i i0); auto.
+ rewrite Int64.not_ltu. destruct (Int64.ltu i i0); simpl; destruct (Int64.eq i i0); auto.
+ rewrite (Int64.ltu_not i i0). destruct (Int64.ltu i i0); destruct (Int64.eq i i0); reflexivity.
+ destruct (Int64.ltu i i0); reflexivity.
+- (* int ptr *)
+ unfold Val.cmplu; simpl; destruct Archi.ptr64; try discriminate.
+ destruct (Int64.eq i Int64.zero &&
+ (Mem.valid_pointer m b0 (Ptrofs.unsigned i0) || Mem.valid_pointer m b0 (Ptrofs.unsigned i0 - 1))) eqn:?; try discriminate H.
+ destruct c; simpl in *; inv H; auto.
+- (* ptr int *)
+ unfold Val.cmplu; simpl; destruct Archi.ptr64; try discriminate.
+ destruct (Int64.eq i0 Int64.zero &&
+ (Mem.valid_pointer m b0 (Ptrofs.unsigned i) || Mem.valid_pointer m b0 (Ptrofs.unsigned i - 1))) eqn:?; try discriminate H.
+ destruct c; simpl in *; inv H; auto.
+- (* ptr ptr *)
+ unfold Val.cmplu; simpl; destruct Archi.ptr64; try discriminate H.
+ fold (Mem.weak_valid_pointer m b0 (Ptrofs.unsigned i)) in *.
+ fold (Mem.weak_valid_pointer m b1 (Ptrofs.unsigned i0)) in *.
+ destruct (eq_block b0 b1).
+ destruct (Mem.weak_valid_pointer m b0 (Ptrofs.unsigned i) &&
+ Mem.weak_valid_pointer m b1 (Ptrofs.unsigned i0)); inv H.
+ destruct c; simpl; auto.
+ destruct (Ptrofs.eq i i0); auto.
+ destruct (Ptrofs.eq i i0); auto.
+ destruct (Ptrofs.ltu i i0); auto.
+ rewrite Ptrofs.not_ltu. destruct (Ptrofs.ltu i i0); simpl; destruct (Ptrofs.eq i i0); auto.
+ rewrite (Ptrofs.ltu_not i i0). destruct (Ptrofs.ltu i i0); destruct (Ptrofs.eq i i0); reflexivity.
+ destruct (Ptrofs.ltu i i0); reflexivity.
+ destruct (Mem.valid_pointer m b0 (Ptrofs.unsigned i) &&
+ Mem.valid_pointer m b1 (Ptrofs.unsigned i0)); try discriminate H.
+ destruct c; simpl in *; inv H; reflexivity.
+Qed.
+
+Lemma compare_floats_spec:
+ forall rs n1 n2,
+ let rs' := nextinstr (compare_floats (Vfloat n1) (Vfloat n2) rs) in
+ rs'#ZF = Val.of_bool (negb (Float.cmp Cne n1 n2))
+ /\ rs'#CF = Val.of_bool (negb (Float.cmp Cge n1 n2))
+ /\ rs'#PF = Val.of_bool (negb (Float.cmp Ceq n1 n2 || Float.cmp Clt n1 n2 || Float.cmp Cgt n1 n2))
+ /\ (forall r, data_preg r = true -> rs'#r = rs#r).
+Proof.
+ intros. unfold rs'; unfold compare_floats.
+ split. auto.
+ split. auto.
+ split. auto.
+ intros. Simplifs.
+Qed.
+
+Lemma compare_floats32_spec:
+ forall rs n1 n2,
+ let rs' := nextinstr (compare_floats32 (Vsingle n1) (Vsingle n2) rs) in
+ rs'#ZF = Val.of_bool (negb (Float32.cmp Cne n1 n2))
+ /\ rs'#CF = Val.of_bool (negb (Float32.cmp Cge n1 n2))
+ /\ rs'#PF = Val.of_bool (negb (Float32.cmp Ceq n1 n2 || Float32.cmp Clt n1 n2 || Float32.cmp Cgt n1 n2))
+ /\ (forall r, data_preg r = true -> rs'#r = rs#r).
+Proof.
+ intros. unfold rs'; unfold compare_floats32.
+ split. auto.
+ split. auto.
+ split. auto.
+ intros. Simplifs.
+Qed.
+
+Definition eval_extcond (xc: extcond) (rs: regset) : option bool :=
+ match xc with
+ | Cond_base c =>
+ eval_testcond c rs
+ | Cond_and c1 c2 =>
+ match eval_testcond c1 rs, eval_testcond c2 rs with
+ | Some b1, Some b2 => Some (b1 && b2)
+ | _, _ => None
+ end
+ | Cond_or c1 c2 =>
+ match eval_testcond c1 rs, eval_testcond c2 rs with
+ | Some b1, Some b2 => Some (b1 || b2)
+ | _, _ => None
+ end
+ end.
+
+Definition swap_floats {A: Type} (c: comparison) (n1 n2: A) : A :=
+ match c with
+ | Clt | Cle => n2
+ | Ceq | Cne | Cgt | Cge => n1
+ end.
+
+Lemma testcond_for_float_comparison_correct:
+ forall c n1 n2 rs,
+ eval_extcond (testcond_for_condition (Ccompf c))
+ (nextinstr (compare_floats (Vfloat (swap_floats c n1 n2))
+ (Vfloat (swap_floats c n2 n1)) rs)) =
+ Some(Float.cmp c n1 n2).
+Proof.
+ intros.
+ generalize (compare_floats_spec rs (swap_floats c n1 n2) (swap_floats c n2 n1)).
+ set (rs' := nextinstr (compare_floats (Vfloat (swap_floats c n1 n2))
+ (Vfloat (swap_floats c n2 n1)) rs)).
+ intros [A [B [C D]]].
+ unfold eval_extcond, eval_testcond. rewrite A; rewrite B; rewrite C.
+ destruct c; simpl.
+(* eq *)
+ rewrite Float.cmp_ne_eq.
+ caseEq (Float.cmp Ceq n1 n2); intros.
+ auto.
+ simpl. destruct (Float.cmp Clt n1 n2 || Float.cmp Cgt n1 n2); auto.
+(* ne *)
+ rewrite Float.cmp_ne_eq.
+ caseEq (Float.cmp Ceq n1 n2); intros.
+ auto.
+ simpl. destruct (Float.cmp Clt n1 n2 || Float.cmp Cgt n1 n2); auto.
+(* lt *)
+ rewrite <- (Float.cmp_swap Cge n1 n2).
+ rewrite <- (Float.cmp_swap Cne n1 n2).
+ simpl.
+ rewrite Float.cmp_ne_eq. rewrite Float.cmp_le_lt_eq.
+ caseEq (Float.cmp Clt n1 n2); intros; simpl.
+ caseEq (Float.cmp Ceq n1 n2); intros; simpl.
+ elimtype False. eapply Float.cmp_lt_eq_false; eauto.
+ auto.
+ destruct (Float.cmp Ceq n1 n2); auto.
+(* le *)
+ rewrite <- (Float.cmp_swap Cge n1 n2). simpl.
+ destruct (Float.cmp Cle n1 n2); auto.
+(* gt *)
+ rewrite Float.cmp_ne_eq. rewrite Float.cmp_ge_gt_eq.
+ caseEq (Float.cmp Cgt n1 n2); intros; simpl.
+ caseEq (Float.cmp Ceq n1 n2); intros; simpl.
+ elimtype False. eapply Float.cmp_gt_eq_false; eauto.
+ auto.
+ destruct (Float.cmp Ceq n1 n2); auto.
+(* ge *)
+ destruct (Float.cmp Cge n1 n2); auto.
+Qed.
+
+Lemma testcond_for_neg_float_comparison_correct:
+ forall c n1 n2 rs,
+ eval_extcond (testcond_for_condition (Cnotcompf c))
+ (nextinstr (compare_floats (Vfloat (swap_floats c n1 n2))
+ (Vfloat (swap_floats c n2 n1)) rs)) =
+ Some(negb(Float.cmp c n1 n2)).
+Proof.
+ intros.
+ generalize (compare_floats_spec rs (swap_floats c n1 n2) (swap_floats c n2 n1)).
+ set (rs' := nextinstr (compare_floats (Vfloat (swap_floats c n1 n2))
+ (Vfloat (swap_floats c n2 n1)) rs)).
+ intros [A [B [C D]]].
+ unfold eval_extcond, eval_testcond. rewrite A; rewrite B; rewrite C.
+ destruct c; simpl.
+(* eq *)
+ rewrite Float.cmp_ne_eq.
+ caseEq (Float.cmp Ceq n1 n2); intros.
+ auto.
+ simpl. destruct (Float.cmp Clt n1 n2 || Float.cmp Cgt n1 n2); auto.
+(* ne *)
+ rewrite Float.cmp_ne_eq.
+ caseEq (Float.cmp Ceq n1 n2); intros.
+ auto.
+ simpl. destruct (Float.cmp Clt n1 n2 || Float.cmp Cgt n1 n2); auto.
+(* lt *)
+ rewrite <- (Float.cmp_swap Cge n1 n2).
+ rewrite <- (Float.cmp_swap Cne n1 n2).
+ simpl.
+ rewrite Float.cmp_ne_eq. rewrite Float.cmp_le_lt_eq.
+ caseEq (Float.cmp Clt n1 n2); intros; simpl.
+ caseEq (Float.cmp Ceq n1 n2); intros; simpl.
+ elimtype False. eapply Float.cmp_lt_eq_false; eauto.
+ auto.
+ destruct (Float.cmp Ceq n1 n2); auto.
+(* le *)
+ rewrite <- (Float.cmp_swap Cge n1 n2). simpl.
+ destruct (Float.cmp Cle n1 n2); auto.
+(* gt *)
+ rewrite Float.cmp_ne_eq. rewrite Float.cmp_ge_gt_eq.
+ caseEq (Float.cmp Cgt n1 n2); intros; simpl.
+ caseEq (Float.cmp Ceq n1 n2); intros; simpl.
+ elimtype False. eapply Float.cmp_gt_eq_false; eauto.
+ auto.
+ destruct (Float.cmp Ceq n1 n2); auto.
+(* ge *)
+ destruct (Float.cmp Cge n1 n2); auto.
+Qed.
+
+Lemma testcond_for_float32_comparison_correct:
+ forall c n1 n2 rs,
+ eval_extcond (testcond_for_condition (Ccompfs c))
+ (nextinstr (compare_floats32 (Vsingle (swap_floats c n1 n2))
+ (Vsingle (swap_floats c n2 n1)) rs)) =
+ Some(Float32.cmp c n1 n2).
+Proof.
+ intros.
+ generalize (compare_floats32_spec rs (swap_floats c n1 n2) (swap_floats c n2 n1)).
+ set (rs' := nextinstr (compare_floats32 (Vsingle (swap_floats c n1 n2))
+ (Vsingle (swap_floats c n2 n1)) rs)).
+ intros [A [B [C D]]].
+ unfold eval_extcond, eval_testcond. rewrite A; rewrite B; rewrite C.
+ destruct c; simpl.
+(* eq *)
+ rewrite Float32.cmp_ne_eq.
+ caseEq (Float32.cmp Ceq n1 n2); intros.
+ auto.
+ simpl. destruct (Float32.cmp Clt n1 n2 || Float32.cmp Cgt n1 n2); auto.
+(* ne *)
+ rewrite Float32.cmp_ne_eq.
+ caseEq (Float32.cmp Ceq n1 n2); intros.
+ auto.
+ simpl. destruct (Float32.cmp Clt n1 n2 || Float32.cmp Cgt n1 n2); auto.
+(* lt *)
+ rewrite <- (Float32.cmp_swap Cge n1 n2).
+ rewrite <- (Float32.cmp_swap Cne n1 n2).
+ simpl.
+ rewrite Float32.cmp_ne_eq. rewrite Float32.cmp_le_lt_eq.
+ caseEq (Float32.cmp Clt n1 n2); intros; simpl.
+ caseEq (Float32.cmp Ceq n1 n2); intros; simpl.
+ elimtype False. eapply Float32.cmp_lt_eq_false; eauto.
+ auto.
+ destruct (Float32.cmp Ceq n1 n2); auto.
+(* le *)
+ rewrite <- (Float32.cmp_swap Cge n1 n2). simpl.
+ destruct (Float32.cmp Cle n1 n2); auto.
+(* gt *)
+ rewrite Float32.cmp_ne_eq. rewrite Float32.cmp_ge_gt_eq.
+ caseEq (Float32.cmp Cgt n1 n2); intros; simpl.
+ caseEq (Float32.cmp Ceq n1 n2); intros; simpl.
+ elimtype False. eapply Float32.cmp_gt_eq_false; eauto.
+ auto.
+ destruct (Float32.cmp Ceq n1 n2); auto.
+(* ge *)
+ destruct (Float32.cmp Cge n1 n2); auto.
+Qed.
+
+Lemma testcond_for_neg_float32_comparison_correct:
+ forall c n1 n2 rs,
+ eval_extcond (testcond_for_condition (Cnotcompfs c))
+ (nextinstr (compare_floats32 (Vsingle (swap_floats c n1 n2))
+ (Vsingle (swap_floats c n2 n1)) rs)) =
+ Some(negb(Float32.cmp c n1 n2)).
+Proof.
+ intros.
+ generalize (compare_floats32_spec rs (swap_floats c n1 n2) (swap_floats c n2 n1)).
+ set (rs' := nextinstr (compare_floats32 (Vsingle (swap_floats c n1 n2))
+ (Vsingle (swap_floats c n2 n1)) rs)).
+ intros [A [B [C D]]].
+ unfold eval_extcond, eval_testcond. rewrite A; rewrite B; rewrite C.
+ destruct c; simpl.
+(* eq *)
+ rewrite Float32.cmp_ne_eq.
+ caseEq (Float32.cmp Ceq n1 n2); intros.
+ auto.
+ simpl. destruct (Float32.cmp Clt n1 n2 || Float32.cmp Cgt n1 n2); auto.
+(* ne *)
+ rewrite Float32.cmp_ne_eq.
+ caseEq (Float32.cmp Ceq n1 n2); intros.
+ auto.
+ simpl. destruct (Float32.cmp Clt n1 n2 || Float32.cmp Cgt n1 n2); auto.
+(* lt *)
+ rewrite <- (Float32.cmp_swap Cge n1 n2).
+ rewrite <- (Float32.cmp_swap Cne n1 n2).
+ simpl.
+ rewrite Float32.cmp_ne_eq. rewrite Float32.cmp_le_lt_eq.
+ caseEq (Float32.cmp Clt n1 n2); intros; simpl.
+ caseEq (Float32.cmp Ceq n1 n2); intros; simpl.
+ elimtype False. eapply Float32.cmp_lt_eq_false; eauto.
+ auto.
+ destruct (Float32.cmp Ceq n1 n2); auto.
+(* le *)
+ rewrite <- (Float32.cmp_swap Cge n1 n2). simpl.
+ destruct (Float32.cmp Cle n1 n2); auto.
+(* gt *)
+ rewrite Float32.cmp_ne_eq. rewrite Float32.cmp_ge_gt_eq.
+ caseEq (Float32.cmp Cgt n1 n2); intros; simpl.
+ caseEq (Float32.cmp Ceq n1 n2); intros; simpl.
+ elimtype False. eapply Float32.cmp_gt_eq_false; eauto.
+ auto.
+ destruct (Float32.cmp Ceq n1 n2); auto.
+(* ge *)
+ destruct (Float32.cmp Cge n1 n2); auto.
+Qed.
+
+Remark swap_floats_commut:
+ forall (A B: Type) c (f: A -> B) x y, swap_floats c (f x) (f y) = f (swap_floats c x y).
+Proof.
+ intros. destruct c; auto.
+Qed.
+
+Remark compare_floats_inv:
+ forall vx vy rs r,
+ r <> CR ZF -> r <> CR CF -> r <> CR PF -> r <> CR SF -> r <> CR OF ->
+ compare_floats vx vy rs r = rs r.
+Proof.
+ intros.
+ assert (DFL: undef_regs (CR ZF :: CR CF :: CR PF :: CR SF :: CR OF :: nil) rs r = rs r).
+ simpl. Simplifs.
+ unfold compare_floats; destruct vx; destruct vy; auto. Simplifs.
+Qed.
+
+Remark compare_floats32_inv:
+ forall vx vy rs r,
+ r <> CR ZF -> r <> CR CF -> r <> CR PF -> r <> CR SF -> r <> CR OF ->
+ compare_floats32 vx vy rs r = rs r.
+Proof.
+ intros.
+ assert (DFL: undef_regs (CR ZF :: CR CF :: CR PF :: CR SF :: CR OF :: nil) rs r = rs r).
+ simpl. Simplifs.
+ unfold compare_floats32; destruct vx; destruct vy; auto. Simplifs.
+Qed.
+
+Lemma transl_cond_correct:
+ forall cond args k c rs m,
+ transl_cond cond args k = OK c ->
+ exists rs',
+ exec_straight ge fn c rs m k rs' m
+ /\ match eval_condition cond (map rs (map preg_of args)) m with
+ | None => True
+ | Some b => eval_extcond (testcond_for_condition cond) rs' = Some b
+ end
+ /\ forall r, data_preg r = true -> rs'#r = rs r.
+Proof.
+ unfold transl_cond; intros.
+ destruct cond; repeat (destruct args; try discriminate); monadInv H.
+- (* comp *)
+ simpl. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1).
+ econstructor. split. apply exec_straight_one. simpl. eauto. auto.
+ split. destruct (Val.cmp_bool c0 (rs x) (rs x0)) eqn:?; auto.
+ eapply testcond_for_signed_comparison_32_correct; eauto.
+ intros. unfold compare_ints. Simplifs.
+- (* compu *)
+ simpl. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1).
+ econstructor. split. apply exec_straight_one. simpl. eauto. auto.
+ split. destruct (Val.cmpu_bool (Mem.valid_pointer m) c0 (rs x) (rs x0)) eqn:?; auto.
+ eapply testcond_for_unsigned_comparison_32_correct; eauto.
+ intros. unfold compare_ints. Simplifs.
+- (* compimm *)
+ simpl. rewrite (ireg_of_eq _ _ EQ). destruct (Int.eq_dec n Int.zero).
+ econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ split. destruct (rs x); simpl; auto. subst. rewrite Int.and_idem.
+ eapply testcond_for_signed_comparison_32_correct; eauto.
+ intros. unfold compare_ints. Simplifs.
+ econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ split. destruct (Val.cmp_bool c0 (rs x) (Vint n)) eqn:?; auto.
+ eapply testcond_for_signed_comparison_32_correct; eauto.
+ intros. unfold compare_ints. Simplifs.
+- (* compuimm *)
+ simpl. rewrite (ireg_of_eq _ _ EQ).
+ econstructor. split. apply exec_straight_one. simpl. eauto. auto.
+ split. destruct (Val.cmpu_bool (Mem.valid_pointer m) c0 (rs x) (Vint n)) eqn:?; auto.
+ eapply testcond_for_unsigned_comparison_32_correct; eauto.
+ intros. unfold compare_ints. Simplifs.
+- (* compl *)
+ simpl. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1).
+ econstructor. split. apply exec_straight_one. simpl. eauto. auto.
+ split. destruct (Val.cmpl_bool c0 (rs x) (rs x0)) eqn:?; auto.
+ eapply testcond_for_signed_comparison_64_correct; eauto.
+ intros. unfold compare_longs. Simplifs.
+- (* complu *)
+ simpl. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1).
+ econstructor. split. apply exec_straight_one. simpl. eauto. auto.
+ split. destruct (Val.cmplu_bool (Mem.valid_pointer m) c0 (rs x) (rs x0)) eqn:?; auto.
+ eapply testcond_for_unsigned_comparison_64_correct; eauto.
+ intros. unfold compare_longs. Simplifs.
+- (* compimm *)
+ simpl. rewrite (ireg_of_eq _ _ EQ). destruct (Int64.eq_dec n Int64.zero).
+ econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ split. destruct (rs x); simpl; auto. subst. rewrite Int64.and_idem.
+ eapply testcond_for_signed_comparison_64_correct; eauto.
+ intros. unfold compare_longs. Simplifs.
+ econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ split. destruct (Val.cmpl_bool c0 (rs x) (Vlong n)) eqn:?; auto.
+ eapply testcond_for_signed_comparison_64_correct; eauto.
+ intros. unfold compare_longs. Simplifs.
+- (* compuimm *)
+ simpl. rewrite (ireg_of_eq _ _ EQ).
+ econstructor. split. apply exec_straight_one. simpl. eauto. auto.
+ split. destruct (Val.cmplu_bool (Mem.valid_pointer m) c0 (rs x) (Vlong n)) eqn:?; auto.
+ eapply testcond_for_unsigned_comparison_64_correct; eauto.
+ intros. unfold compare_longs. Simplifs.
+- (* compf *)
+ simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1).
+ exists (nextinstr (compare_floats (swap_floats c0 (rs x) (rs x0)) (swap_floats c0 (rs x0) (rs x)) rs)).
+ split. apply exec_straight_one.
+ destruct c0; simpl; auto.
+ unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats_inv; auto with asmgen.
+ split. destruct (rs x); destruct (rs x0); simpl; auto.
+ repeat rewrite swap_floats_commut. apply testcond_for_float_comparison_correct.
+ intros. Simplifs. apply compare_floats_inv; auto with asmgen.
+- (* notcompf *)
+ simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1).
+ exists (nextinstr (compare_floats (swap_floats c0 (rs x) (rs x0)) (swap_floats c0 (rs x0) (rs x)) rs)).
+ split. apply exec_straight_one.
+ destruct c0; simpl; auto.
+ unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats_inv; auto with asmgen.
+ split. destruct (rs x); destruct (rs x0); simpl; auto.
+ repeat rewrite swap_floats_commut. apply testcond_for_neg_float_comparison_correct.
+ intros. Simplifs. apply compare_floats_inv; auto with asmgen.
+- (* compfs *)
+ simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1).
+ exists (nextinstr (compare_floats32 (swap_floats c0 (rs x) (rs x0)) (swap_floats c0 (rs x0) (rs x)) rs)).
+ split. apply exec_straight_one.
+ destruct c0; simpl; auto.
+ unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats32_inv; auto with asmgen.
+ split. destruct (rs x); destruct (rs x0); simpl; auto.
+ repeat rewrite swap_floats_commut. apply testcond_for_float32_comparison_correct.
+ intros. Simplifs. apply compare_floats32_inv; auto with asmgen.
+- (* notcompfs *)
+ simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1).
+ exists (nextinstr (compare_floats32 (swap_floats c0 (rs x) (rs x0)) (swap_floats c0 (rs x0) (rs x)) rs)).
+ split. apply exec_straight_one.
+ destruct c0; simpl; auto.
+ unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats32_inv; auto with asmgen.
+ split. destruct (rs x); destruct (rs x0); simpl; auto.
+ repeat rewrite swap_floats_commut. apply testcond_for_neg_float32_comparison_correct.
+ intros. Simplifs. apply compare_floats32_inv; auto with asmgen.
+- (* maskzero *)
+ simpl. rewrite (ireg_of_eq _ _ EQ).
+ econstructor. split. apply exec_straight_one. simpl; eauto. auto.
+ split. destruct (rs x); simpl; auto.
+ generalize (compare_ints_spec rs (Vint (Int.and i n)) Vzero m).
+ intros [A B]. rewrite A. unfold Val.cmpu; simpl. destruct (Int.eq (Int.and i n) Int.zero); auto.
+ intros. unfold compare_ints. Simplifs.
+- (* masknotzero *)
+ simpl. rewrite (ireg_of_eq _ _ EQ).
+ econstructor. split. apply exec_straight_one. simpl; eauto. auto.
+ split. destruct (rs x); simpl; auto.
+ generalize (compare_ints_spec rs (Vint (Int.and i n)) Vzero m).
+ intros [A B]. rewrite A. unfold Val.cmpu; simpl. destruct (Int.eq (Int.and i n) Int.zero); auto.
+ intros. unfold compare_ints. Simplifs.
+Qed.
+
+Remark eval_testcond_nextinstr:
+ forall c rs, eval_testcond c (nextinstr rs) = eval_testcond c rs.
+Proof.
+ intros. unfold eval_testcond. repeat rewrite nextinstr_inv; auto with asmgen.
+Qed.
+
+Remark eval_testcond_set_ireg:
+ forall c rs r v, eval_testcond c (rs#(IR r) <- v) = eval_testcond c rs.
+Proof.
+ intros. unfold eval_testcond. repeat rewrite Pregmap.gso; auto with asmgen.
+Qed.
+
+Lemma mk_setcc_base_correct:
+ forall cond rd k rs1 m,
+ exists rs2,
+ exec_straight ge fn (mk_setcc_base cond rd k) rs1 m k rs2 m
+ /\ rs2#rd = Val.of_optbool(eval_extcond cond rs1)
+ /\ forall r, data_preg r = true -> r <> RAX /\ r <> RCX -> r <> rd -> rs2#r = rs1#r.
+Proof.
+ intros. destruct cond; simpl in *.
+- (* base *)
+ econstructor; split.
+ apply exec_straight_one. simpl; eauto. auto.
+ split. Simplifs. intros; Simplifs.
+- (* or *)
+ assert (Val.of_optbool
+ match eval_testcond c1 rs1 with
+ | Some b1 =>
+ match eval_testcond c2 rs1 with
+ | Some b2 => Some (b1 || b2)
+ | None => None
+ end
+ | None => None
+ end =
+ Val.or (Val.of_optbool (eval_testcond c1 rs1)) (Val.of_optbool (eval_testcond c2 rs1))).
+ destruct (eval_testcond c1 rs1). destruct (eval_testcond c2 rs1).
+ destruct b; destruct b0; auto.
+ destruct b; auto.
+ auto.
+ rewrite H; clear H.
+ destruct (ireg_eq rd RAX).
+ subst rd. econstructor; split.
+ eapply exec_straight_three.
+ simpl; eauto.
+ simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. eauto.
+ simpl; eauto.
+ auto. auto. auto.
+ intuition Simplifs.
+ econstructor; split.
+ eapply exec_straight_three.
+ simpl; eauto.
+ simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. eauto.
+ simpl. eauto.
+ auto. auto. auto.
+ split. Simplifs. rewrite Val.or_commut. decEq; Simplifs.
+ intros. destruct H0; Simplifs.
+- (* and *)
+ assert (Val.of_optbool
+ match eval_testcond c1 rs1 with
+ | Some b1 =>
+ match eval_testcond c2 rs1 with
+ | Some b2 => Some (b1 && b2)
+ | None => None
+ end
+ | None => None
+ end =
+ Val.and (Val.of_optbool (eval_testcond c1 rs1)) (Val.of_optbool (eval_testcond c2 rs1))).
+ {
+ destruct (eval_testcond c1 rs1). destruct (eval_testcond c2 rs1).
+ destruct b; destruct b0; auto.
+ destruct b; auto.
+ auto.
+ }
+ rewrite H; clear H.
+ destruct (ireg_eq rd RAX).
+ subst rd. econstructor; split.
+ eapply exec_straight_three.
+ simpl; eauto.
+ simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. eauto.
+ simpl; eauto.
+ auto. auto. auto.
+ intuition Simplifs.
+ econstructor; split.
+ eapply exec_straight_three.
+ simpl; eauto.
+ simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. eauto.
+ simpl. eauto.
+ auto. auto. auto.
+ split. Simplifs. rewrite Val.and_commut. decEq; Simplifs.
+ intros. destruct H0; Simplifs.
+Qed.
+
+Lemma mk_setcc_correct:
+ forall cond rd k rs1 m,
+ exists rs2,
+ exec_straight ge fn (mk_setcc cond rd k) rs1 m k rs2 m
+ /\ rs2#rd = Val.of_optbool(eval_extcond cond rs1)
+ /\ forall r, data_preg r = true -> r <> RAX /\ r <> RCX -> r <> rd -> rs2#r = rs1#r.
+Proof.
+ intros. unfold mk_setcc. destruct (Archi.ptr64 || low_ireg rd).
+- apply mk_setcc_base_correct.
+- exploit mk_setcc_base_correct. intros [rs2 [A [B C]]].
+ econstructor; split. eapply exec_straight_trans. eexact A. apply exec_straight_one.
+ simpl. eauto. simpl. auto.
+ intuition Simplifs.
+Qed.
+
+(** Translation of arithmetic operations. *)
+
+Ltac ArgsInv :=
+ match goal with
+ | [ H: Error _ = OK _ |- _ ] => discriminate
+ | [ H: match ?args with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct args; ArgsInv
+ | [ H: bind _ _ = OK _ |- _ ] => monadInv H; ArgsInv
+ | [ H: match _ with left _ => _ | right _ => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv
+ | [ H: match _ with true => _ | false => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv
+ | [ H: ireg_of _ = OK _ |- _ ] => simpl in *; rewrite (ireg_of_eq _ _ H) in *; clear H; ArgsInv
+ | [ H: freg_of _ = OK _ |- _ ] => simpl in *; rewrite (freg_of_eq _ _ H) in *; clear H; ArgsInv
+ | _ => idtac
+ end.
+
+Ltac TranslOp :=
+ econstructor; split;
+ [ apply exec_straight_one; [ simpl; eauto | auto ]
+ | split; [ Simplifs | intros; Simplifs ]].
+
+Lemma transl_op_correct:
+ forall op args res k c (rs: regset) m v,
+ transl_op op args res k = OK c ->
+ eval_operation ge (rs#RSP) op (map rs (map preg_of args)) m = Some v ->
+ exists rs',
+ exec_straight ge fn c rs m k rs' m
+ /\ Val.lessdef v rs'#(preg_of res)
+ /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r.
+Proof.
+Transparent destroyed_by_op.
+ intros until v; intros TR EV.
+ assert (SAME:
+ (exists rs',
+ exec_straight ge fn c rs m k rs' m
+ /\ rs'#(preg_of res) = v
+ /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r) ->
+ exists rs',
+ exec_straight ge fn c rs m k rs' m
+ /\ Val.lessdef v rs'#(preg_of res)
+ /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r).
+ {
+ intros [rs' [A [B C]]]. subst v. exists rs'; auto.
+ }
+
+ destruct op; simpl in TR; ArgsInv; simpl in EV; try (inv EV); try (apply SAME; TranslOp; fail).
+(* move *)
+ exploit mk_mov_correct; eauto. intros [rs2 [A [B C]]].
+ apply SAME. exists rs2. eauto.
+(* intconst *)
+ apply SAME. destruct (Int.eq_dec n Int.zero). subst n. TranslOp. TranslOp.
+(* longconst *)
+ apply SAME. destruct (Int64.eq_dec n Int64.zero). subst n. TranslOp. TranslOp.
+(* floatconst *)
+ apply SAME. destruct (Float.eq_dec n Float.zero). subst n. TranslOp. TranslOp.
+(* singleconst *)
+ apply SAME. destruct (Float32.eq_dec n Float32.zero). subst n. TranslOp. TranslOp.
+(* cast8signed *)
+ apply SAME. eapply mk_intconv_correct; eauto.
+(* cast8unsigned *)
+ apply SAME. eapply mk_intconv_correct; eauto.
+(* mulhs *)
+ apply SAME. TranslOp. destruct H1. Simplifs.
+(* mulhu *)
+ apply SAME. TranslOp. destruct H1. Simplifs.
+(* div *)
+ apply SAME.
+ exploit (divs_mods_exists (rs RAX) (rs RCX)). left; congruence.
+ intros (nh & nl & d & q & r & A & B & C & D & E & F).
+ set (rs1 := nextinstr_nf (rs#RDX <- (Vint nh))).
+ econstructor; split.
+ eapply exec_straight_two with (rs2 := rs1). simpl. rewrite A. reflexivity.
+ simpl. change (rs1 RAX) with (rs RAX); rewrite B.
+ change (rs1 RCX) with (rs RCX); rewrite C.
+ rewrite D. reflexivity. auto. auto.
+ split. change (Vint q = v). congruence.
+ simpl; intros. destruct H2. unfold rs1; Simplifs.
+(* divu *)
+ apply SAME.
+ exploit (divu_modu_exists (rs RAX) (rs RCX)). left; congruence.
+ intros (n & d & q & r & B & C & D & E & F).
+ set (rs1 := nextinstr_nf (rs#RDX <- Vzero)).
+ econstructor; split.
+ eapply exec_straight_two with (rs2 := rs1). reflexivity.
+ simpl. change (rs1 RAX) with (rs RAX); rewrite B.
+ change (rs1 RCX) with (rs RCX); rewrite C.
+ rewrite D. reflexivity. auto. auto.
+ split. change (Vint q = v). congruence.
+ simpl; intros. destruct H2. unfold rs1; Simplifs.
+(* mod *)
+ apply SAME.
+ exploit (divs_mods_exists (rs RAX) (rs RCX)). right; congruence.
+ intros (nh & nl & d & q & r & A & B & C & D & E & F).
+ set (rs1 := nextinstr_nf (rs#RDX <- (Vint nh))).
+ econstructor; split.
+ eapply exec_straight_two with (rs2 := rs1). simpl. rewrite A. reflexivity.
+ simpl. change (rs1 RAX) with (rs RAX); rewrite B.
+ change (rs1 RCX) with (rs RCX); rewrite C.
+ rewrite D. reflexivity. auto. auto.
+ split. change (Vint r = v). congruence.
+ simpl; intros. destruct H2. unfold rs1; Simplifs.
+(* modu *)
+ apply SAME.
+ exploit (divu_modu_exists (rs RAX) (rs RCX)). right; congruence.
+ intros (n & d & q & r & B & C & D & E & F).
+ set (rs1 := nextinstr_nf (rs#RDX <- Vzero)).
+ econstructor; split.
+ eapply exec_straight_two with (rs2 := rs1). reflexivity.
+ simpl. change (rs1 RAX) with (rs RAX); rewrite B.
+ change (rs1 RCX) with (rs RCX); rewrite C.
+ rewrite D. reflexivity. auto. auto.
+ split. change (Vint r = v). congruence.
+ simpl; intros. destruct H2. unfold rs1; Simplifs.
+(* shrximm *)
+ apply SAME. eapply mk_shrximm_correct; eauto.
+(* lea *)
+ exploit transl_addressing_mode_32_correct; eauto. intros EA.
+ TranslOp. rewrite nextinstr_inv; auto with asmgen. rewrite Pregmap.gss. rewrite normalize_addrmode_32_correct; auto.
+(* mullhs *)
+ apply SAME. TranslOp. destruct H1. Simplifs.
+(* mullhu *)
+ apply SAME. TranslOp. destruct H1. Simplifs.
+(* divl *)
+ apply SAME.
+ exploit (divls_modls_exists (rs RAX) (rs RCX)). left; congruence.
+ intros (nh & nl & d & q & r & A & B & C & D & E & F).
+ set (rs1 := nextinstr_nf (rs#RDX <- (Vlong nh))).
+ econstructor; split.
+ eapply exec_straight_two with (rs2 := rs1). simpl. rewrite A. reflexivity.
+ simpl. change (rs1 RAX) with (rs RAX); rewrite B.
+ change (rs1 RCX) with (rs RCX); rewrite C.
+ rewrite D. reflexivity. auto. auto.
+ split. change (Vlong q = v). congruence.
+ simpl; intros. destruct H2. unfold rs1; Simplifs.
+(* divlu *)
+ apply SAME.
+ exploit (divlu_modlu_exists (rs RAX) (rs RCX)). left; congruence.
+ intros (n & d & q & r & B & C & D & E & F).
+ set (rs1 := nextinstr_nf (rs#RDX <- (Vlong Int64.zero))).
+ econstructor; split.
+ eapply exec_straight_two with (rs2 := rs1). reflexivity.
+ simpl. change (rs1 RAX) with (rs RAX); rewrite B.
+ change (rs1 RCX) with (rs RCX); rewrite C.
+ rewrite D. reflexivity. auto. auto.
+ split. change (Vlong q = v). congruence.
+ simpl; intros. destruct H2. unfold rs1; Simplifs.
+(* modl *)
+ apply SAME.
+ exploit (divls_modls_exists (rs RAX) (rs RCX)). right; congruence.
+ intros (nh & nl & d & q & r & A & B & C & D & E & F).
+ set (rs1 := nextinstr_nf (rs#RDX <- (Vlong nh))).
+ econstructor; split.
+ eapply exec_straight_two with (rs2 := rs1). simpl. rewrite A. reflexivity.
+ simpl. change (rs1 RAX) with (rs RAX); rewrite B.
+ change (rs1 RCX) with (rs RCX); rewrite C.
+ rewrite D. reflexivity. auto. auto.
+ split. change (Vlong r = v). congruence.
+ simpl; intros. destruct H2. unfold rs1; Simplifs.
+(* modlu *)
+ apply SAME.
+ exploit (divlu_modlu_exists (rs RAX) (rs RCX)). right; congruence.
+ intros (n & d & q & r & B & C & D & E & F).
+ set (rs1 := nextinstr_nf (rs#RDX <- (Vlong Int64.zero))).
+ econstructor; split.
+ eapply exec_straight_two with (rs2 := rs1). reflexivity.
+ simpl. change (rs1 RAX) with (rs RAX); rewrite B.
+ change (rs1 RCX) with (rs RCX); rewrite C.
+ rewrite D. reflexivity. auto. auto.
+ split. change (Vlong r = v). congruence.
+ simpl; intros. destruct H2. unfold rs1; Simplifs.
+(* shrxlimm *)
+ apply SAME. eapply mk_shrxlimm_correct; eauto.
+(* leal *)
+ exploit transl_addressing_mode_64_correct; eauto. intros EA.
+ generalize (normalize_addrmode_64_correct x rs). destruct (normalize_addrmode_64 x) as [am' [delta|]]; intros EV.
+ econstructor; split. eapply exec_straight_two.
+ simpl. reflexivity. simpl. reflexivity. auto. auto.
+ split. rewrite nextinstr_nf_inv by auto. rewrite Pregmap.gss. rewrite nextinstr_inv by auto with asmgen.
+ rewrite Pregmap.gss. rewrite <- EV; auto.
+ intros; Simplifs.
+ TranslOp. rewrite nextinstr_inv; auto with asmgen. rewrite Pregmap.gss; auto. rewrite <- EV; auto.
+(* intoffloat *)
+ apply SAME. TranslOp. rewrite H0; auto.
+(* floatofint *)
+ apply SAME. TranslOp. rewrite H0; auto.
+(* intofsingle *)
+ apply SAME. TranslOp. rewrite H0; auto.
+(* singleofint *)
+ apply SAME. TranslOp. rewrite H0; auto.
+(* longoffloat *)
+ apply SAME. TranslOp. rewrite H0; auto.
+(* floatoflong *)
+ apply SAME. TranslOp. rewrite H0; auto.
+(* longofsingle *)
+ apply SAME. TranslOp. rewrite H0; auto.
+(* singleoflong *)
+ apply SAME. TranslOp. rewrite H0; auto.
+(* condition *)
+ exploit transl_cond_correct; eauto. intros [rs2 [P [Q R]]].
+ exploit mk_setcc_correct; eauto. intros [rs3 [S [T U]]].
+ exists rs3.
+ split. eapply exec_straight_trans. eexact P. eexact S.
+ split. rewrite T. destruct (eval_condition cond rs ## (preg_of ## args) m).
+ rewrite Q. auto.
+ simpl; auto.
+ intros. transitivity (rs2 r); auto.
+Qed.
+
+(** Translation of memory loads. *)
+
+Lemma transl_load_correct:
+ forall chunk addr args dest k c (rs: regset) m a v,
+ transl_load chunk addr args dest k = OK c ->
+ eval_addressing ge (rs#RSP) addr (map rs (map preg_of args)) = Some a ->
+ Mem.loadv chunk m a = Some v ->
+ exists rs',
+ exec_straight ge fn c rs m k rs' m
+ /\ rs'#(preg_of dest) = v
+ /\ forall r, data_preg r = true -> r <> preg_of dest -> rs'#r = rs#r.
+Proof.
+ unfold transl_load; intros. monadInv H.
+ exploit transl_addressing_mode_correct; eauto. intro EA.
+ assert (EA': eval_addrmode ge x rs = a). destruct a; simpl in H1; try discriminate; inv EA; auto.
+ set (rs2 := nextinstr_nf (rs#(preg_of dest) <- v)).
+ assert (exec_load ge chunk m x rs (preg_of dest) = Next rs2 m).
+ unfold exec_load. rewrite EA'. rewrite H1. auto.
+ assert (rs2 PC = Val.offset_ptr (rs PC) Ptrofs.one).
+ transitivity (Val.offset_ptr ((rs#(preg_of dest) <- v) PC) Ptrofs.one).
+ auto. decEq. apply Pregmap.gso; auto with asmgen.
+ exists rs2. split.
+ destruct chunk; ArgsInv; apply exec_straight_one; auto.
+ split. unfold rs2. rewrite nextinstr_nf_inv1. Simplifs. apply preg_of_data.
+ intros. unfold rs2. Simplifs.
+Qed.
+
+Lemma transl_store_correct:
+ forall chunk addr args src k c (rs: regset) m a m',
+ transl_store chunk addr args src k = OK c ->
+ eval_addressing ge (rs#RSP) addr (map rs (map preg_of args)) = Some a ->
+ Mem.storev chunk m a (rs (preg_of src)) = Some m' ->
+ exists rs',
+ exec_straight ge fn c rs m k rs' m'
+ /\ forall r, data_preg r = true -> preg_notin r (destroyed_by_store chunk addr) -> rs'#r = rs#r.
+Proof.
+ unfold transl_store; intros. monadInv H.
+ exploit transl_addressing_mode_correct; eauto. intro EA.
+ assert (EA': eval_addrmode ge x rs = a). destruct a; simpl in H1; try discriminate; inv EA; auto.
+ rewrite <- EA' in H1. destruct chunk; ArgsInv.
+(* int8signed *)
+ eapply mk_storebyte_correct; eauto.
+ destruct (eval_addrmode ge x rs); simpl; auto. rewrite <- Mem.store_signed_unsigned_8; auto.
+(* int8unsigned *)
+ eapply mk_storebyte_correct; eauto.
+(* int16signed *)
+ econstructor; split.
+ apply exec_straight_one. simpl. unfold exec_store.
+ replace (Mem.storev Mint16unsigned m (eval_addrmode ge x rs) (rs x0))
+ with (Mem.storev Mint16signed m (eval_addrmode ge x rs) (rs x0)).
+ rewrite H1. eauto.
+ destruct (eval_addrmode ge x rs); simpl; auto. rewrite Mem.store_signed_unsigned_16; auto.
+ auto.
+ intros. Simplifs.
+(* int16unsigned *)
+ econstructor; split.
+ apply exec_straight_one. simpl. unfold exec_store. rewrite H1. eauto. auto.
+ intros. Simplifs.
+(* int32 *)
+ econstructor; split.
+ apply exec_straight_one. simpl. unfold exec_store. rewrite H1. eauto. auto.
+ intros. Simplifs.
+(* int64 *)
+ econstructor; split.
+ apply exec_straight_one. simpl. unfold exec_store. rewrite H1. eauto. auto.
+ intros. Simplifs.
+(* float32 *)
+ econstructor; split.
+ apply exec_straight_one. simpl. unfold exec_store. rewrite H1. eauto. auto.
+ intros. Transparent destroyed_by_store. simpl in H2. simpl. Simplifs.
+(* float64 *)
+ econstructor; split.
+ apply exec_straight_one. simpl. unfold exec_store. rewrite H1. eauto. auto.
+ intros. Simplifs.
+Qed.
+
+End CONSTRUCTORS.
diff --git a/x86/CBuiltins.ml b/x86/CBuiltins.ml
new file mode 100644
index 00000000..09303223
--- /dev/null
+++ b/x86/CBuiltins.ml
@@ -0,0 +1,94 @@
+(* *********************************************************************)
+(* *)
+(* 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 GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Processor-dependent builtin C functions *)
+
+open C
+
+let (va_list_type, va_list_scalar, size_va_list) =
+ if Archi.ptr64 then
+ (* Actually a struct passed by reference; equivalent to 3 64-bit words *)
+ (TArray(TInt(IULong, []), Some 3L, []), false, 3*8)
+ else
+ (* Just a pointer *)
+ (TPtr(TVoid [], []), true, 4)
+
+let builtins = {
+ Builtins.typedefs = [
+ "__builtin_va_list", va_list_type;
+ ];
+ Builtins.functions = [
+ (* Integer arithmetic *)
+ "__builtin_bswap",
+ (TInt(IUInt, []), [TInt(IUInt, [])], false);
+ "__builtin_bswap64",
+ (TInt(IULongLong, []), [TInt(IULongLong, [])], false);
+ "__builtin_bswap32",
+ (TInt(IUInt, []), [TInt(IUInt, [])], false);
+ "__builtin_bswap16",
+ (TInt(IUShort, []), [TInt(IUShort, [])], false);
+ "__builtin_clz",
+ (TInt(IInt, []), [TInt(IUInt, [])], false);
+ "__builtin_clzl",
+ (TInt(IInt, []), [TInt(IULong, [])], false);
+ "__builtin_clzll",
+ (TInt(IInt, []), [TInt(IULongLong, [])], false);
+ "__builtin_ctz",
+ (TInt(IInt, []), [TInt(IUInt, [])], false);
+ "__builtin_ctzl",
+ (TInt(IInt, []), [TInt(IULong, [])], false);
+ "__builtin_ctzll",
+ (TInt(IInt, []), [TInt(IULongLong, [])], false);
+ (* Float arithmetic *)
+ "__builtin_fsqrt",
+ (TFloat(FDouble, []), [TFloat(FDouble, [])], false);
+ "__builtin_fmax",
+ (TFloat(FDouble, []), [TFloat(FDouble, []); TFloat(FDouble, [])], false);
+ "__builtin_fmin",
+ (TFloat(FDouble, []), [TFloat(FDouble, []); TFloat(FDouble, [])], false);
+ "__builtin_fmadd",
+ (TFloat(FDouble, []),
+ [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])],
+ false);
+ "__builtin_fmsub",
+ (TFloat(FDouble, []),
+ [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])],
+ false);
+ "__builtin_fnmadd",
+ (TFloat(FDouble, []),
+ [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])],
+ false);
+ "__builtin_fnmsub",
+ (TFloat(FDouble, []),
+ [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])],
+ false);
+ (* Memory accesses *)
+ "__builtin_read16_reversed",
+ (TInt(IUShort, []), [TPtr(TInt(IUShort, [AConst]), [])], false);
+ "__builtin_read32_reversed",
+ (TInt(IUInt, []), [TPtr(TInt(IUInt, [AConst]), [])], false);
+ "__builtin_write16_reversed",
+ (TVoid [], [TPtr(TInt(IUShort, []), []); TInt(IUShort, [])], false);
+ "__builtin_write32_reversed",
+ (TVoid [], [TPtr(TInt(IUInt, []), []); TInt(IUInt, [])], false);
+ (* no operation *)
+ "__builtin_nop",
+ (TVoid [], [], false);
+ ]
+}
+
+(* Expand memory references inside extended asm statements. Used in C2C. *)
+
+let asm_mem_argument arg = Printf.sprintf "0(%s)" arg
diff --git a/x86/CombineOp.v b/x86/CombineOp.v
new file mode 100644
index 00000000..34c1c9cc
--- /dev/null
+++ b/x86/CombineOp.v
@@ -0,0 +1,150 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris *)
+(* *)
+(* 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. *)
+(* *)
+(* *********************************************************************)
+
+(** Recognition of combined operations, addressing modes and conditions
+ during the [CSE] phase. *)
+
+Require Import Coqlib.
+Require Import AST Integers.
+Require Import Op CSEdomain.
+
+Definition valnum := positive.
+
+Section COMBINE.
+
+Variable get: valnum -> option rhs.
+
+Function combine_compimm_ne_0 (x: valnum) : option(condition * list valnum) :=
+ match get x with
+ | Some(Op (Ocmp c) ys) => Some (c, ys)
+ | Some(Op (Oandimm n) ys) => Some (Cmasknotzero n, ys)
+ | _ => None
+ end.
+
+Function combine_compimm_eq_0 (x: valnum) : option(condition * list valnum) :=
+ match get x with
+ | Some(Op (Ocmp c) ys) => Some (negate_condition c, ys)
+ | Some(Op (Oandimm n) ys) => Some (Cmaskzero n, ys)
+ | _ => None
+ end.
+
+Function combine_compimm_eq_1 (x: valnum) : option(condition * list valnum) :=
+ match get x with
+ | Some(Op (Ocmp c) ys) => Some (c, ys)
+ | _ => None
+ end.
+
+Function combine_compimm_ne_1 (x: valnum) : option(condition * list valnum) :=
+ match get x with
+ | Some(Op (Ocmp c) ys) => Some (negate_condition c, ys)
+ | _ => None
+ end.
+
+Function combine_cond (cond: condition) (args: list valnum) : option(condition * list valnum) :=
+ match cond, args with
+ | Ccompimm Cne n, x::nil =>
+ if Int.eq_dec n Int.zero then combine_compimm_ne_0 x
+ else if Int.eq_dec n Int.one then combine_compimm_ne_1 x
+ else None
+ | Ccompimm Ceq n, x::nil =>
+ if Int.eq_dec n Int.zero then combine_compimm_eq_0 x
+ else if Int.eq_dec n Int.one then combine_compimm_eq_1 x
+ else None
+ | Ccompuimm Cne n, x::nil =>
+ if Int.eq_dec n Int.zero then combine_compimm_ne_0 x
+ else if Int.eq_dec n Int.one then combine_compimm_ne_1 x
+ else None
+ | Ccompuimm Ceq n, x::nil =>
+ if Int.eq_dec n Int.zero then combine_compimm_eq_0 x
+ else if Int.eq_dec n Int.one then combine_compimm_eq_1 x
+ else None
+ | _, _ => None
+ end.
+
+Function combine_addr_32 (addr: addressing) (args: list valnum) : option(addressing * list valnum) :=
+ match addr, args with
+ | Aindexed n, x::nil =>
+ match get x with
+ | Some(Op (Olea a) ys) =>
+ match offset_addressing a n with Some a' => Some (a', ys) | None => None end
+ | _ => None
+ end
+ | _, _ => None
+ end.
+
+Function combine_addr_64 (addr: addressing) (args: list valnum) : option(addressing * list valnum) :=
+ match addr, args with
+ | Aindexed n, x::nil =>
+ match get x with
+ | Some(Op (Oleal a) ys) =>
+ match offset_addressing a n with Some a' => Some (a', ys) | None => None end
+ | _ => None
+ end
+ | _, _ => None
+ end.
+
+Definition combine_addr (addr: addressing) (args: list valnum) : option(addressing * list valnum) :=
+ if Archi.ptr64 then combine_addr_64 addr args else combine_addr_32 addr args.
+
+Function combine_op (op: operation) (args: list valnum) : option(operation * list valnum) :=
+ match op, args with
+ | Olea addr, _ =>
+ match combine_addr_32 addr args with
+ | Some(addr', args') => Some(Olea addr', args')
+ | None => None
+ end
+ | Oleal addr, _ =>
+ match combine_addr_64 addr args with
+ | Some(addr', args') => Some(Oleal addr', args')
+ | None => None
+ end
+ | Oandimm n, x :: nil =>
+ match get x with
+ | Some(Op (Oandimm m) ys) => Some(Oandimm (Int.and m n), ys)
+ | _ => None
+ end
+ | Oorimm n, x :: nil =>
+ match get x with
+ | Some(Op (Oorimm m) ys) => Some(Oorimm (Int.or m n), ys)
+ | _ => None
+ end
+ | Oxorimm n, x :: nil =>
+ match get x with
+ | Some(Op (Oxorimm m) ys) => Some(Oxorimm (Int.xor m n), ys)
+ | _ => None
+ end
+ | Oandlimm n, x :: nil =>
+ match get x with
+ | Some(Op (Oandlimm m) ys) => Some(Oandlimm (Int64.and m n), ys)
+ | _ => None
+ end
+ | Oorlimm n, x :: nil =>
+ match get x with
+ | Some(Op (Oorlimm m) ys) => Some(Oorlimm (Int64.or m n), ys)
+ | _ => None
+ end
+ | Oxorlimm n, x :: nil =>
+ match get x with
+ | Some(Op (Oxorlimm m) ys) => Some(Oxorlimm (Int64.xor m n), ys)
+ | _ => None
+ end
+ | Ocmp cond, _ =>
+ match combine_cond cond args with
+ | Some(cond', args') => Some(Ocmp cond', args')
+ | None => None
+ end
+ | _, _ => None
+ end.
+
+End COMBINE.
+
+
diff --git a/x86/CombineOpproof.v b/x86/CombineOpproof.v
new file mode 100644
index 00000000..f59e582b
--- /dev/null
+++ b/x86/CombineOpproof.v
@@ -0,0 +1,179 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris *)
+(* *)
+(* 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. *)
+(* *)
+(* *********************************************************************)
+
+(** Recognition of combined operations, addressing modes and conditions
+ during the [CSE] phase. *)
+
+Require Import Coqlib.
+Require Import Integers Values Memory.
+Require Import Op RTL CSEdomain.
+Require Import CombineOp.
+
+Section COMBINE.
+
+Variable ge: genv.
+Variable sp: val.
+Variable m: mem.
+Variable get: valnum -> option rhs.
+Variable valu: valnum -> val.
+Hypothesis get_sound: forall v rhs, get v = Some rhs -> rhs_eval_to valu ge sp m rhs (valu v).
+
+Lemma get_op_sound:
+ forall v op vl, get v = Some (Op op vl) -> eval_operation ge sp op (map valu vl) m = Some (valu v).
+Proof.
+ intros. exploit get_sound; eauto. intros REV; inv REV; auto.
+Qed.
+
+Ltac UseGetSound :=
+ match goal with
+ | [ H: get _ = Some _ |- _ ] =>
+ let x := fresh "EQ" in (generalize (get_op_sound _ _ _ H); intros x; simpl in x; FuncInv)
+ end.
+
+Lemma combine_compimm_ne_0_sound:
+ forall x cond args,
+ combine_compimm_ne_0 get x = Some(cond, args) ->
+ eval_condition cond (map valu args) m = Val.cmp_bool Cne (valu x) (Vint Int.zero) /\
+ eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Cne (valu x) (Vint Int.zero).
+Proof.
+ intros until args. functional induction (combine_compimm_ne_0 get x); intros EQ; inv EQ.
+ (* of cmp *)
+ UseGetSound. rewrite <- H.
+ destruct (eval_condition cond (map valu args) m); simpl; auto. destruct b; auto.
+ (* of and *)
+ UseGetSound. rewrite <- H.
+ destruct v; simpl; auto.
+Qed.
+
+Lemma combine_compimm_eq_0_sound:
+ forall x cond args,
+ combine_compimm_eq_0 get x = Some(cond, args) ->
+ eval_condition cond (map valu args) m = Val.cmp_bool Ceq (valu x) (Vint Int.zero) /\
+ eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Ceq (valu x) (Vint Int.zero).
+Proof.
+ intros until args. functional induction (combine_compimm_eq_0 get x); intros EQ; inv EQ.
+ (* of cmp *)
+ UseGetSound. rewrite <- H.
+ rewrite eval_negate_condition.
+ destruct (eval_condition c (map valu args) m); simpl; auto. destruct b; auto.
+ (* of and *)
+ UseGetSound. rewrite <- H. destruct v; auto.
+Qed.
+
+Lemma combine_compimm_eq_1_sound:
+ forall x cond args,
+ combine_compimm_eq_1 get x = Some(cond, args) ->
+ eval_condition cond (map valu args) m = Val.cmp_bool Ceq (valu x) (Vint Int.one) /\
+ eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Ceq (valu x) (Vint Int.one).
+Proof.
+ intros until args. functional induction (combine_compimm_eq_1 get x); intros EQ; inv EQ.
+ (* of cmp *)
+ UseGetSound. rewrite <- H.
+ destruct (eval_condition cond (map valu args) m); simpl; auto. destruct b; auto.
+Qed.
+
+Lemma combine_compimm_ne_1_sound:
+ forall x cond args,
+ combine_compimm_ne_1 get x = Some(cond, args) ->
+ eval_condition cond (map valu args) m = Val.cmp_bool Cne (valu x) (Vint Int.one) /\
+ eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Cne (valu x) (Vint Int.one).
+Proof.
+ intros until args. functional induction (combine_compimm_ne_1 get x); intros EQ; inv EQ.
+ (* of cmp *)
+ UseGetSound. rewrite <- H.
+ rewrite eval_negate_condition.
+ destruct (eval_condition c (map valu args) m); simpl; auto. destruct b; auto.
+Qed.
+
+Theorem combine_cond_sound:
+ forall cond args cond' args',
+ combine_cond get cond args = Some(cond', args') ->
+ eval_condition cond' (map valu args') m = eval_condition cond (map valu args) m.
+Proof.
+ intros. functional inversion H; subst.
+ (* compimm ne zero *)
+ simpl; eapply combine_compimm_ne_0_sound; eauto.
+ (* compimm ne one *)
+ simpl; eapply combine_compimm_ne_1_sound; eauto.
+ (* compimm eq zero *)
+ simpl; eapply combine_compimm_eq_0_sound; eauto.
+ (* compimm eq one *)
+ simpl; eapply combine_compimm_eq_1_sound; eauto.
+ (* compuimm ne zero *)
+ simpl; eapply combine_compimm_ne_0_sound; eauto.
+ (* compuimm ne one *)
+ simpl; eapply combine_compimm_ne_1_sound; eauto.
+ (* compuimm eq zero *)
+ simpl; eapply combine_compimm_eq_0_sound; eauto.
+ (* compuimm eq one *)
+ simpl; eapply combine_compimm_eq_1_sound; eauto.
+Qed.
+
+Theorem combine_addr_32_sound:
+ forall addr args addr' args',
+ combine_addr_32 get addr args = Some(addr', args') ->
+ eval_addressing32 ge sp addr' (map valu args') = eval_addressing32 ge sp addr (map valu args).
+Proof.
+ intros. functional inversion H; subst.
+ (* indexed - lea *)
+ UseGetSound. simpl. unfold offset_addressing in H7. destruct (addressing_valid (offset_addressing_total a n)); inv H7.
+ eapply eval_offset_addressing_total_32; eauto.
+Qed.
+
+Theorem combine_addr_64_sound:
+ forall addr args addr' args',
+ combine_addr_64 get addr args = Some(addr', args') ->
+ eval_addressing64 ge sp addr' (map valu args') = eval_addressing64 ge sp addr (map valu args).
+Proof.
+ intros. functional inversion H; subst.
+ (* indexed - leal *)
+ UseGetSound. simpl. unfold offset_addressing in H7. destruct (addressing_valid (offset_addressing_total a n)); inv H7.
+ eapply eval_offset_addressing_total_64; eauto.
+Qed.
+
+Theorem combine_addr_sound:
+ forall addr args addr' args',
+ combine_addr get addr args = Some(addr', args') ->
+ eval_addressing ge sp addr' (map valu args') = eval_addressing ge sp addr (map valu args).
+Proof.
+ unfold combine_addr, eval_addressing; intros; destruct Archi.ptr64.
+ apply combine_addr_64_sound; auto.
+ apply combine_addr_32_sound; auto.
+Qed.
+
+Theorem combine_op_sound:
+ forall op args op' args',
+ combine_op get op args = Some(op', args') ->
+ eval_operation ge sp op' (map valu args') m = eval_operation ge sp op (map valu args) m.
+Proof.
+ intros. functional inversion H; subst.
+(* lea-lea *)
+ simpl. eapply combine_addr_32_sound; eauto.
+(* leal-leal *)
+ simpl. eapply combine_addr_64_sound; eauto.
+(* andimm - andimm *)
+ UseGetSound; simpl. rewrite <- H0. rewrite Val.and_assoc. auto.
+(* orimm - orimm *)
+ UseGetSound; simpl. rewrite <- H0. rewrite Val.or_assoc. auto.
+(* xorimm - xorimm *)
+ UseGetSound; simpl. rewrite <- H0. rewrite Val.xor_assoc. auto.
+(* andimm - andimm *)
+ UseGetSound; simpl. rewrite <- H0. rewrite Val.andl_assoc. auto.
+(* orimm - orimm *)
+ UseGetSound; simpl. rewrite <- H0. rewrite Val.orl_assoc. auto.
+(* xorimm - xorimm *)
+ UseGetSound; simpl. rewrite <- H0. rewrite Val.xorl_assoc. auto.
+(* cmp *)
+ simpl. decEq; decEq. eapply combine_cond_sound; eauto.
+Qed.
+
+End COMBINE.
diff --git a/x86/ConstpropOp.vp b/x86/ConstpropOp.vp
new file mode 100644
index 00000000..0bf143d2
--- /dev/null
+++ b/x86/ConstpropOp.vp
@@ -0,0 +1,404 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris *)
+(* *)
+(* 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. *)
+(* *)
+(* *********************************************************************)
+
+(** Strength reduction for operators and conditions.
+ This is the machine-dependent part of [Constprop]. *)
+
+Require Import Coqlib Compopts.
+Require Import AST Integers Floats.
+Require Import Op Registers.
+Require Import ValueDomain.
+
+(** * Converting known values to constants *)
+
+Parameter symbol_is_external: ident -> bool. (**r See [SelectOp] *)
+
+Definition Olea_ptr (a: addressing) := if Archi.ptr64 then Oleal a else Olea a.
+
+Definition const_for_result (a: aval) : option operation :=
+ match a with
+ | I n => Some(Ointconst n)
+ | L n => if Archi.ptr64 then Some(Olongconst n) else None
+ | F n => if Compopts.generate_float_constants tt then Some(Ofloatconst n) else None
+ | FS n => if Compopts.generate_float_constants tt then Some(Osingleconst n) else None
+ | Ptr(Gl id ofs) =>
+ if symbol_is_external id then
+ if Ptrofs.eq ofs Ptrofs.zero then Some (Oindirectsymbol id) else None
+ else
+ Some (Olea_ptr (Aglobal id ofs))
+ | Ptr(Stk ofs) => Some(Olea_ptr (Ainstack ofs))
+ | _ => None
+ end.
+
+(** * 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. *)
+
+Nondetfunction cond_strength_reduction
+ (cond: condition) (args: list reg) (vl: list aval) :=
+ match cond, args, vl with
+ | Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil =>
+ (Ccompimm (swap_comparison c) n1, r2 :: nil)
+ | Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil =>
+ (Ccompimm c n2, r1 :: nil)
+ | Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil =>
+ (Ccompuimm (swap_comparison c) n1, r2 :: nil)
+ | Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil =>
+ (Ccompuimm c n2, r1 :: nil)
+ | Ccompl c, r1 :: r2 :: nil, L n1 :: v2 :: nil =>
+ (Ccomplimm (swap_comparison c) n1, r2 :: nil)
+ | Ccompl c, r1 :: r2 :: nil, v1 :: L n2 :: nil =>
+ (Ccomplimm c n2, r1 :: nil)
+ | Ccomplu c, r1 :: r2 :: nil, L n1 :: v2 :: nil =>
+ (Ccompluimm (swap_comparison c) n1, r2 :: nil)
+ | Ccomplu c, r1 :: r2 :: nil, v1 :: L n2 :: nil =>
+ (Ccompluimm c n2, r1 :: nil)
+ | _, _, _ =>
+ (cond, args)
+ end.
+
+Definition make_cmp_base (c: condition) (args: list reg) (vl: list aval) :=
+ let (c', args') := cond_strength_reduction c args vl in (Ocmp c', args').
+
+Nondetfunction make_cmp (c: condition) (args: list reg) (vl: list aval) :=
+ match c, args, vl with
+ | Ccompimm Ceq n, r1 :: nil, v1 :: nil =>
+ if Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1) then (Omove, r1 :: nil)
+ else if Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1) then (Oxorimm Int.one, r1 :: nil)
+ else make_cmp_base c args vl
+ | Ccompimm Cne n, r1 :: nil, v1 :: nil =>
+ if Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1) then (Omove, r1 :: nil)
+ else if Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1) then (Oxorimm Int.one, r1 :: nil)
+ else make_cmp_base c args vl
+ | _, _, _ =>
+ make_cmp_base c args vl
+ end.
+
+(** For addressing modes, we need to distinguish
+- reductions that produce pointers (i.e. that produce [Aglobal], [Ainstack], [Abased] and [Abasedscaled] addressing modes), which are valid only if the pointer size is right;
+- other reductions (producing [Aindexed] or [Aindexed2] modes), which are valid independently of the pointer size.
+*)
+
+Nondetfunction addr_strength_reduction_32_generic
+ (addr: addressing) (args: list reg) (vl: list aval) :=
+ match addr, args, vl with
+ | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: v2 :: nil =>
+ (Aindexed (Int.signed n1 + ofs), r2 :: nil)
+ | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil =>
+ (Aindexed (Int.signed n2 + ofs), r1 :: nil)
+ | Aindexed2scaled sc ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil =>
+ (Aindexed (Int.signed n2 * sc + ofs), r1 :: nil)
+ | Aindexed2scaled sc ofs, r1 :: r2 :: nil, I n1 :: v2 :: nil =>
+ (Ascaled sc (Int.signed n1 + ofs), r2 :: nil)
+ | _, _ =>
+ (addr, args)
+ end.
+
+Nondetfunction addr_strength_reduction_32
+ (addr: addressing) (args: list reg) (vl: list aval) :=
+
+ if Archi.ptr64 then addr_strength_reduction_32_generic addr args vl else
+
+ match addr, args, vl with
+
+ | Aindexed ofs, r1 :: nil, Ptr(Gl symb n) :: nil =>
+ (Aglobal symb (Ptrofs.add n (Ptrofs.repr ofs)), nil)
+ | Aindexed ofs, r1 :: nil, Ptr(Stk n) :: nil =>
+ (Ainstack (Ptrofs.add n (Ptrofs.repr ofs)), nil)
+
+ | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: I n2 :: nil =>
+ (Aglobal symb (Ptrofs.add (Ptrofs.add n1 (Ptrofs.of_int n2)) (Ptrofs.repr ofs)), nil)
+ | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: Ptr(Gl symb n2) :: nil =>
+ (Aglobal symb (Ptrofs.add (Ptrofs.add n2 (Ptrofs.of_int n1)) (Ptrofs.repr ofs)), nil)
+ | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Stk n1) :: I n2 :: nil =>
+ (Ainstack (Ptrofs.add (Ptrofs.add n1 (Ptrofs.of_int n2)) (Ptrofs.repr ofs)), nil)
+ | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: Ptr(Stk n2) :: nil =>
+ (Ainstack (Ptrofs.add (Ptrofs.add (Ptrofs.of_int n1) n2) (Ptrofs.repr ofs)), nil)
+ | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: v2 :: nil =>
+ (Abased symb (Ptrofs.add n1 (Ptrofs.repr ofs)), r2 :: nil)
+ | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: Ptr(Gl symb n2) :: nil =>
+ (Abased symb (Ptrofs.add n2 (Ptrofs.repr ofs)), r1 :: nil)
+
+ | Aindexed2scaled sc ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: I n2 :: nil =>
+ (Aglobal symb (Ptrofs.add (Ptrofs.add n1 (Ptrofs.of_int (Int.mul n2 (Int.repr sc)))) (Ptrofs.repr ofs)), nil)
+
+ | Aindexed2scaled sc ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: v2 :: nil =>
+ (Abasedscaled sc symb (Ptrofs.add n1 (Ptrofs.repr ofs)), r2 :: nil)
+
+ | Abased id ofs, r1 :: nil, I n1 :: nil =>
+ (Aglobal id (Ptrofs.add ofs (Ptrofs.of_int n1)), nil)
+
+ | Abasedscaled sc id ofs, r1 :: nil, I n1 :: nil =>
+ (Aglobal id (Ptrofs.add ofs (Ptrofs.of_int (Int.mul n1 (Int.repr sc)))), nil)
+
+ | _, _ =>
+ addr_strength_reduction_32_generic addr args vl
+ end.
+
+Nondetfunction addr_strength_reduction_64_generic
+ (addr: addressing) (args: list reg) (vl: list aval) :=
+ match addr, args, vl with
+ | Aindexed2 ofs, r1 :: r2 :: nil, L n1 :: v2 :: nil =>
+ (Aindexed (Int64.signed n1 + ofs), r2 :: nil)
+ | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: L n2 :: nil =>
+ (Aindexed (Int64.signed n2 + ofs), r1 :: nil)
+ | Aindexed2scaled sc ofs, r1 :: r2 :: nil, v1 :: L n2 :: nil =>
+ (Aindexed (Int64.signed n2 * sc + ofs), r1 :: nil)
+ | Aindexed2scaled sc ofs, r1 :: r2 :: nil, L n1 :: v2 :: nil =>
+ (Ascaled sc (Int64.signed n1 + ofs), r2 :: nil)
+ | _, _ =>
+ (addr, args)
+ end.
+
+Nondetfunction addr_strength_reduction_64
+ (addr: addressing) (args: list reg) (vl: list aval) :=
+
+ if negb Archi.ptr64 then addr_strength_reduction_64_generic addr args vl else
+
+ match addr, args, vl with
+
+ | Aindexed ofs, r1 :: nil, Ptr(Gl symb n) :: nil =>
+ (Aglobal symb (Ptrofs.add n (Ptrofs.repr ofs)), nil)
+ | Aindexed ofs, r1 :: nil, Ptr(Stk n) :: nil =>
+ (Ainstack (Ptrofs.add n (Ptrofs.repr ofs)), nil)
+
+ | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: L n2 :: nil =>
+ (Aglobal symb (Ptrofs.add (Ptrofs.add n1 (Ptrofs.of_int64 n2)) (Ptrofs.repr ofs)), nil)
+ | Aindexed2 ofs, r1 :: r2 :: nil, L n1 :: Ptr(Gl symb n2) :: nil =>
+ (Aglobal symb (Ptrofs.add (Ptrofs.add n2 (Ptrofs.of_int64 n1)) (Ptrofs.repr ofs)), nil)
+ | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Stk n1) :: L n2 :: nil =>
+ (Ainstack (Ptrofs.add (Ptrofs.add n1 (Ptrofs.of_int64 n2)) (Ptrofs.repr ofs)), nil)
+ | Aindexed2 ofs, r1 :: r2 :: nil, L n1 :: Ptr(Stk n2) :: nil =>
+ (Ainstack (Ptrofs.add (Ptrofs.add (Ptrofs.of_int64 n1) n2) (Ptrofs.repr ofs)), nil)
+
+ | Aindexed2scaled sc ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: L n2 :: nil =>
+ (Aglobal symb (Ptrofs.add (Ptrofs.add n1 (Ptrofs.of_int64 (Int64.mul n2 (Int64.repr sc)))) (Ptrofs.repr ofs)), nil)
+
+ | _, _ =>
+ addr_strength_reduction_64_generic addr args vl
+ end.
+
+Definition addr_strength_reduction
+ (addr: addressing) (args: list reg) (vl: list aval) :=
+ if Archi.ptr64
+ then addr_strength_reduction_64 addr args vl
+ else addr_strength_reduction_32 addr args vl.
+
+Definition make_addimm (n: int) (r: reg) :=
+ if Int.eq n Int.zero
+ then (Omove, r :: nil)
+ else (Olea (Aindexed (Int.signed n)), r :: nil).
+
+Definition make_shlimm (n: int) (r1 r2: reg) :=
+ if Int.eq n Int.zero then (Omove, r1 :: nil)
+ else if Int.ltu n Int.iwordsize then (Oshlimm n, r1 :: nil)
+ else (Oshl, r1 :: r2 :: nil).
+
+Definition make_shrimm (n: int) (r1 r2: reg) :=
+ if Int.eq n Int.zero then (Omove, r1 :: nil)
+ else if Int.ltu n Int.iwordsize then (Oshrimm n, r1 :: nil)
+ else (Oshr, r1 :: r2 :: nil).
+
+Definition make_shruimm (n: int) (r1 r2: reg) :=
+ if Int.eq n Int.zero then (Omove, r1 :: nil)
+ else if Int.ltu n Int.iwordsize then (Oshruimm n, r1 :: nil)
+ else (Oshru, r1 :: r2 :: 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 => (Oshlimm l, r :: nil)
+ | None => (Omulimm n, r :: nil)
+ end.
+
+Definition make_andimm (n: int) (r: reg) (a: aval) :=
+ if Int.eq n Int.zero then (Ointconst Int.zero, nil)
+ else if Int.eq n Int.mone then (Omove, r :: nil)
+ else if match a with Uns _ m => Int.eq (Int.zero_ext m (Int.not n)) Int.zero
+ | _ => false end
+ 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 if Int.eq n Int.mone then (Onot, r :: nil)
+ else (Oxorimm n, r :: nil).
+
+Definition make_divimm n (r1 r2: reg) :=
+ match Int.is_power2 n with
+ | Some l => if Int.ltu l (Int.repr 31)
+ then (Oshrximm l, r1 :: nil)
+ else (Odiv, r1 :: r2 :: nil)
+ | None => (Odiv, r1 :: r2 :: nil)
+ end.
+
+Definition make_divuimm n (r1 r2: reg) :=
+ match Int.is_power2 n with
+ | Some l => (Oshruimm l, r1 :: nil)
+ | None => (Odivu, r1 :: r2 :: nil)
+ end.
+
+Definition make_moduimm n (r1 r2: reg) :=
+ match Int.is_power2 n with
+ | Some l => (Oandimm (Int.sub n Int.one), r1 :: nil)
+ | None => (Omodu, r1 :: r2 :: nil)
+ end.
+
+Definition make_addlimm (n: int64) (r: reg) :=
+ if Int64.eq n Int64.zero
+ then (Omove, r :: nil)
+ else (Oleal (Aindexed (Int64.signed n)), r :: nil).
+
+Definition make_shllimm (n: int) (r1 r2: reg) :=
+ if Int.eq n Int.zero then (Omove, r1 :: nil)
+ else if Int.ltu n Int64.iwordsize' then (Oshllimm n, r1 :: nil)
+ else (Oshll, r1 :: r2 :: nil).
+
+Definition make_shrlimm (n: int) (r1 r2: reg) :=
+ if Int.eq n Int.zero then (Omove, r1 :: nil)
+ else if Int.ltu n Int64.iwordsize' then (Oshrlimm n, r1 :: nil)
+ else (Oshrl, r1 :: r2 :: nil).
+
+Definition make_shrluimm (n: int) (r1 r2: reg) :=
+ if Int.eq n Int.zero then (Omove, r1 :: nil)
+ else if Int.ltu n Int64.iwordsize' then (Oshrluimm n, r1 :: nil)
+ else (Oshrlu, r1 :: r2 :: nil).
+
+Definition make_mullimm (n: int64) (r: reg) :=
+ if Int64.eq n Int64.zero then
+ (Olongconst Int64.zero, nil)
+ else if Int64.eq n Int64.one then
+ (Omove, r :: nil)
+ else
+ match Int64.is_power2' n with
+ | Some l => (Oshllimm l, r :: nil)
+ | None => (Omullimm n, r :: nil)
+ end.
+
+Definition make_andlimm (n: int64) (r: reg) (a: aval) :=
+ if Int64.eq n Int64.zero then (Olongconst Int64.zero, nil)
+ else if Int64.eq n Int64.mone then (Omove, r :: nil)
+ else (Oandlimm n, r :: nil).
+
+Definition make_orlimm (n: int64) (r: reg) :=
+ if Int64.eq n Int64.zero then (Omove, r :: nil)
+ else if Int64.eq n Int64.mone then (Olongconst Int64.mone, nil)
+ else (Oorlimm n, r :: nil).
+
+Definition make_xorlimm (n: int64) (r: reg) :=
+ if Int64.eq n Int64.zero then (Omove, r :: nil)
+ else if Int64.eq n Int64.mone then (Onotl, r :: nil)
+ else (Oxorlimm n, r :: nil).
+
+Definition make_divlimm n (r1 r2: reg) :=
+ match Int64.is_power2' n with
+ | Some l => if Int.ltu l (Int.repr 63)
+ then (Oshrxlimm l, r1 :: nil)
+ else (Odivl, r1 :: r2 :: nil)
+ | None => (Odivl, r1 :: r2 :: nil)
+ end.
+
+Definition make_divluimm n (r1 r2: reg) :=
+ match Int64.is_power2' n with
+ | Some l => (Oshrluimm l, r1 :: nil)
+ | None => (Odivlu, r1 :: r2 :: nil)
+ end.
+
+Definition make_modluimm n (r1 r2: reg) :=
+ match Int64.is_power2 n with
+ | Some l => (Oandlimm (Int64.sub n Int64.one), r1 :: nil)
+ | None => (Omodlu, r1 :: r2 :: nil)
+ end.
+
+Definition make_mulfimm (n: float) (r r1 r2: reg) :=
+ if Float.eq_dec n (Float.of_int (Int.repr 2))
+ then (Oaddf, r :: r :: nil)
+ else (Omulf, r1 :: r2 :: nil).
+
+Definition make_mulfsimm (n: float32) (r r1 r2: reg) :=
+ if Float32.eq_dec n (Float32.of_int (Int.repr 2))
+ then (Oaddfs, r :: r :: nil)
+ else (Omulfs, r1 :: r2 :: nil).
+
+Definition make_cast8signed (r: reg) (a: aval) :=
+ if vincl a (Sgn Ptop 8) then (Omove, r :: nil) else (Ocast8signed, r :: nil).
+Definition make_cast8unsigned (r: reg) (a: aval) :=
+ if vincl a (Uns Ptop 8) then (Omove, r :: nil) else (Ocast8unsigned, r :: nil).
+Definition make_cast16signed (r: reg) (a: aval) :=
+ if vincl a (Sgn Ptop 16) then (Omove, r :: nil) else (Ocast16signed, r :: nil).
+Definition make_cast16unsigned (r: reg) (a: aval) :=
+ if vincl a (Uns Ptop 16) then (Omove, r :: nil) else (Ocast16unsigned, r :: nil).
+
+Nondetfunction op_strength_reduction
+ (op: operation) (args: list reg) (vl: list aval) :=
+ match op, args, vl with
+ | Ocast8signed, r1 :: nil, v1 :: nil => make_cast8signed r1 v1
+ | Ocast8unsigned, r1 :: nil, v1 :: nil => make_cast8unsigned r1 v1
+ | Ocast16signed, r1 :: nil, v1 :: nil => make_cast16signed r1 v1
+ | Ocast16unsigned, r1 :: nil, v1 :: nil => make_cast16unsigned r1 v1
+ | Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm (Int.neg n2) r1
+ | Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_mulimm n1 r2
+ | Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_mulimm n2 r1
+ | Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divimm n2 r1 r2
+ | Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divuimm n2 r1 r2
+ | Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_moduimm n2 r1 r2
+ | Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_andimm n1 r2 v2
+ | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm n2 r1 v1
+ | Oandimm n, r1 :: nil, v1 :: nil => make_andimm n r1 v1
+ | Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_orimm n1 r2
+ | Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_orimm n2 r1
+ | Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_xorimm n1 r2
+ | Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_xorimm n2 r1
+ | Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shlimm n2 r1 r2
+ | Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrimm n2 r1 r2
+ | Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shruimm n2 r1 r2
+ | Olea addr, args, vl =>
+ let (addr', args') := addr_strength_reduction_32 addr args vl in
+ (Olea addr', args')
+ | Osubl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_addlimm (Int64.neg n2) r1
+ | Omull, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_mullimm n1 r2
+ | Omull, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_mullimm n2 r1
+ | Odivl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_divlimm n2 r1 r2
+ | Odivlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_divluimm n2 r1 r2
+ | Omodlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_modluimm n2 r1 r2
+ | Oandl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_andlimm n1 r2 v2
+ | Oandl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_andlimm n2 r1 v1
+ | Oandlimm n, r1 :: nil, v1 :: nil => make_andlimm n r1 v1
+ | Oorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_orlimm n1 r2
+ | Oorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_orlimm n2 r1
+ | Oxorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_xorlimm n1 r2
+ | Oxorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_xorlimm n2 r1
+ | Oshll, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shllimm n2 r1 r2
+ | Oshrl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrlimm n2 r1 r2
+ | Oshrlu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrluimm n2 r1 r2
+ | Oleal addr, args, vl =>
+ let (addr', args') := addr_strength_reduction_64 addr args vl in
+ (Oleal addr', args')
+ | Ocmp c, args, vl => make_cmp c args vl
+ | Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil => make_mulfimm n2 r1 r1 r2
+ | Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil => make_mulfimm n1 r2 r1 r2
+ | Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil => make_mulfsimm n2 r1 r1 r2
+ | Omulfs, r1 :: r2 :: nil, FS n1 :: v2 :: nil => make_mulfsimm n1 r2 r1 r2
+ | _, _, _ => (op, args)
+ end.
diff --git a/x86/ConstpropOpproof.v b/x86/ConstpropOpproof.v
new file mode 100644
index 00000000..4f582f86
--- /dev/null
+++ b/x86/ConstpropOpproof.v
@@ -0,0 +1,883 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris *)
+(* *)
+(* 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 operator strength reduction. *)
+
+Require Import Coqlib Compopts.
+Require Import Integers Floats Values Memory Globalenvs Events.
+Require Import Op Registers RTL ValueDomain.
+Require Import ConstpropOp.
+
+Section STRENGTH_REDUCTION.
+
+Variable bc: block_classification.
+Variable ge: genv.
+Hypothesis GENV: genv_match bc ge.
+Variable sp: block.
+Hypothesis STACK: bc sp = BCstack.
+Variable ae: AE.t.
+Variable e: regset.
+Variable m: mem.
+Hypothesis MATCH: ematch bc e ae.
+
+Lemma match_G:
+ forall r id ofs,
+ AE.get r ae = Ptr(Gl id ofs) -> Val.lessdef e#r (Genv.symbol_address ge id ofs).
+Proof.
+ intros. apply vmatch_ptr_gl with bc; auto. rewrite <- H. apply MATCH.
+Qed.
+
+Lemma match_S:
+ forall r ofs,
+ AE.get r ae = Ptr(Stk ofs) -> Val.lessdef e#r (Vptr sp ofs).
+Proof.
+ intros. apply vmatch_ptr_stk with bc; auto. rewrite <- H. apply MATCH.
+Qed.
+
+Ltac InvApproxRegs :=
+ match goal with
+ | [ H: _ :: _ = _ :: _ |- _ ] =>
+ injection H; clear H; intros; InvApproxRegs
+ | [ H: ?v = AE.get ?r ae |- _ ] =>
+ generalize (MATCH r); rewrite <- H; clear H; intro; InvApproxRegs
+ | _ => idtac
+ end.
+
+Ltac SimplVM :=
+ match goal with
+ | [ H: vmatch _ ?v (I ?n) |- _ ] =>
+ let E := fresh in
+ assert (E: v = Vint n) by (inversion H; auto);
+ rewrite E in *; clear H; SimplVM
+ | [ H: vmatch _ ?v (L ?n) |- _ ] =>
+ let E := fresh in
+ assert (E: v = Vlong n) by (inversion H; auto);
+ rewrite E in *; clear H; SimplVM
+ | [ H: vmatch _ ?v (F ?n) |- _ ] =>
+ let E := fresh in
+ assert (E: v = Vfloat n) by (inversion H; auto);
+ rewrite E in *; clear H; SimplVM
+ | [ H: vmatch _ ?v (FS ?n) |- _ ] =>
+ let E := fresh in
+ assert (E: v = Vsingle n) by (inversion H; auto);
+ rewrite E in *; clear H; SimplVM
+ | [ H: vmatch _ ?v (Ptr(Gl ?id ?ofs)) |- _ ] =>
+ let E := fresh in
+ assert (E: Val.lessdef v (Genv.symbol_address ge id ofs)) by (eapply vmatch_ptr_gl; eauto);
+ clear H; SimplVM
+ | [ H: vmatch _ ?v (Ptr(Stk ?ofs)) |- _ ] =>
+ let E := fresh in
+ assert (E: Val.lessdef v (Vptr sp ofs)) by (eapply vmatch_ptr_stk; eauto);
+ clear H; SimplVM
+ | _ => idtac
+ end.
+
+Lemma eval_Olea_ptr:
+ forall a el,
+ eval_operation ge (Vptr sp Ptrofs.zero) (Olea_ptr a) el m = eval_addressing ge (Vptr sp Ptrofs.zero) a el.
+Proof.
+ unfold Olea_ptr, eval_addressing; intros. destruct Archi.ptr64; auto.
+Qed.
+
+Lemma const_for_result_correct:
+ forall a op v,
+ const_for_result a = Some op ->
+ vmatch bc v a ->
+ exists v', eval_operation ge (Vptr sp Ptrofs.zero) op nil m = Some v' /\ Val.lessdef v v'.
+Proof.
+ unfold const_for_result. generalize Archi.ptr64; intros ptr64; intros.
+ destruct a; inv H; SimplVM.
+- (* integer *)
+ exists (Vint n); auto.
+- (* long *)
+ destruct ptr64; inv H2. exists (Vlong n); auto.
+- (* float *)
+ destruct (Compopts.generate_float_constants tt); inv H2. exists (Vfloat f); auto.
+- (* single *)
+ destruct (Compopts.generate_float_constants tt); inv H2. exists (Vsingle f); auto.
+- (* pointer *)
+ destruct p; try discriminate; SimplVM.
+ + (* global *)
+ destruct (symbol_is_external id).
+ * revert H2; predSpec Ptrofs.eq Ptrofs.eq_spec ofs Ptrofs.zero; intros EQ; inv EQ.
+ exists (Genv.symbol_address ge id Ptrofs.zero); auto.
+ * inv H2. exists (Genv.symbol_address ge id ofs); split.
+ rewrite eval_Olea_ptr. apply eval_addressing_Aglobal.
+ auto.
+ + (* stack *)
+ inv H2. exists (Vptr sp ofs); split.
+ rewrite eval_Olea_ptr. rewrite eval_addressing_Ainstack.
+ simpl. rewrite Ptrofs.add_zero_l; auto.
+ auto.
+Qed.
+
+Lemma cond_strength_reduction_correct:
+ forall cond args vl,
+ vl = map (fun r => AE.get r ae) args ->
+ let (cond', args') := cond_strength_reduction cond args vl in
+ eval_condition cond' e##args' m = eval_condition cond e##args m.
+Proof.
+ intros until vl. unfold cond_strength_reduction.
+ case (cond_strength_reduction_match cond args vl); simpl; intros; InvApproxRegs; SimplVM.
+- apply Val.swap_cmp_bool.
+- auto.
+- apply Val.swap_cmpu_bool.
+- auto.
+- apply Val.swap_cmpl_bool.
+- auto.
+- apply Val.swap_cmplu_bool.
+- auto.
+- auto.
+Qed.
+
+Lemma addr_strength_reduction_32_generic_correct:
+ forall addr args vl res,
+ vl = map (fun r => AE.get r ae) args ->
+ eval_addressing32 ge (Vptr sp Ptrofs.zero) addr e##args = Some res ->
+ let (addr', args') := addr_strength_reduction_32_generic addr args vl in
+ exists res', eval_addressing32 ge (Vptr sp Ptrofs.zero) addr' e##args' = Some res' /\ Val.lessdef res res'.
+Proof.
+Local Opaque Val.add.
+ assert (A: forall x y, Int.repr (Int.signed x + y) = Int.add x (Int.repr y)).
+ { intros; apply Int.eqm_samerepr; auto using Int.eqm_signed_unsigned with ints. }
+ assert (B: forall x y z, Int.repr (Int.signed x * y + z) = Int.add (Int.mul x (Int.repr y)) (Int.repr z)).
+ { intros; apply Int.eqm_samerepr; apply Int.eqm_add; auto with ints.
+ unfold Int.mul; auto using Int.eqm_signed_unsigned with ints. }
+ intros until res; intros VL EA.
+ unfold addr_strength_reduction_32_generic; destruct (addr_strength_reduction_32_generic_match addr args vl);
+ simpl in *; InvApproxRegs; SimplVM; try (inv EA).
+- econstructor; split; eauto. rewrite A, Val.add_assoc, Val.add_permut. auto.
+- econstructor; split; eauto. rewrite A, Val.add_assoc. auto.
+- Local Transparent Val.add.
+ econstructor; split; eauto. simpl. rewrite B. auto.
+- econstructor; split; eauto. rewrite A, Val.add_permut. auto.
+- exists res; auto.
+Qed.
+
+Lemma addr_strength_reduction_32_correct:
+ forall addr args vl res,
+ vl = map (fun r => AE.get r ae) args ->
+ eval_addressing32 ge (Vptr sp Ptrofs.zero) addr e##args = Some res ->
+ let (addr', args') := addr_strength_reduction_32 addr args vl in
+ exists res', eval_addressing32 ge (Vptr sp Ptrofs.zero) addr' e##args' = Some res' /\ Val.lessdef res res'.
+Proof.
+ intros until res; intros VL EA. unfold addr_strength_reduction_32.
+ destruct Archi.ptr64 eqn:SF. apply addr_strength_reduction_32_generic_correct; auto.
+ assert (A: forall n, Ptrofs.of_int (Int.repr n) = Ptrofs.repr n) by auto with ptrofs.
+ assert (B: forall symb ofs n,
+ Genv.symbol_address ge symb (Ptrofs.add ofs (Ptrofs.repr n)) =
+ Val.add (Genv.symbol_address ge symb ofs) (Vint (Int.repr n))).
+ { intros. rewrite <- A. apply Genv.shift_symbol_address_32; auto. }
+Local Opaque Val.add.
+ destruct (addr_strength_reduction_32_match addr args vl);
+ simpl in *; InvApproxRegs; SimplVM; FuncInv; subst; rewrite ?SF.
+- econstructor; split; eauto. rewrite B. apply Val.add_lessdef; auto.
+- econstructor; split; eauto. rewrite Ptrofs.add_zero_l.
+Local Transparent Val.add.
+ inv H0; auto. rewrite H2. simpl; rewrite SF, A. auto.
+- econstructor; split; eauto.
+ unfold Ptrofs.add at 2. rewrite B.
+ fold (Ptrofs.add n1 (Ptrofs.of_int n2)).
+ rewrite Genv.shift_symbol_address_32 by auto.
+ rewrite ! Val.add_assoc. apply Val.add_lessdef; auto.
+- econstructor; split; eauto.
+ unfold Ptrofs.add at 2. rewrite B.
+ fold (Ptrofs.add n2 (Ptrofs.of_int n1)).
+ rewrite Genv.shift_symbol_address_32 by auto.
+ rewrite ! Val.add_assoc. rewrite Val.add_permut. apply Val.add_lessdef; auto.
+- econstructor; split; eauto. rewrite Ptrofs.add_zero_l. rewrite Val.add_assoc.
+ eapply Val.lessdef_trans. apply Val.add_lessdef; eauto.
+ simpl. rewrite SF. rewrite Ptrofs.add_assoc. apply Val.lessdef_same; do 3 f_equal. auto with ptrofs.
+- econstructor; split; eauto. rewrite Ptrofs.add_zero_l. rewrite Val.add_assoc, Val.add_permut.
+ eapply Val.lessdef_trans. apply Val.add_lessdef; eauto.
+ simpl. rewrite SF. rewrite <- (Ptrofs.add_commut n2). rewrite Ptrofs.add_assoc.
+ apply Val.lessdef_same; do 3 f_equal. auto with ptrofs.
+- econstructor; split; eauto. rewrite B. rewrite ! Val.add_assoc. rewrite (Val.add_commut (Vint (Int.repr ofs))).
+ apply Val.add_lessdef; auto.
+- econstructor; split; eauto. rewrite B. rewrite (Val.add_commut e#r1). rewrite ! Val.add_assoc.
+ rewrite (Val.add_commut (Vint (Int.repr ofs))). apply Val.add_lessdef; auto.
+- econstructor; split; eauto. rewrite B. rewrite Genv.shift_symbol_address_32 by auto.
+ rewrite ! Val.add_assoc. apply Val.add_lessdef; auto.
+- econstructor; split; eauto. rewrite B. rewrite ! Val.add_assoc.
+ rewrite (Val.add_commut (Vint (Int.repr ofs))). apply Val.add_lessdef; auto.
+- econstructor; split; eauto.
+ rewrite Genv.shift_symbol_address_32 by auto. auto.
+- econstructor; split; eauto.
+ rewrite Genv.shift_symbol_address_32 by auto. auto.
+- apply addr_strength_reduction_32_generic_correct; auto.
+Qed.
+
+Lemma addr_strength_reduction_64_generic_correct:
+ forall addr args vl res,
+ vl = map (fun r => AE.get r ae) args ->
+ eval_addressing64 ge (Vptr sp Ptrofs.zero) addr e##args = Some res ->
+ let (addr', args') := addr_strength_reduction_64_generic addr args vl in
+ exists res', eval_addressing64 ge (Vptr sp Ptrofs.zero) addr' e##args' = Some res' /\ Val.lessdef res res'.
+Proof.
+Local Opaque Val.addl.
+ assert (A: forall x y, Int64.repr (Int64.signed x + y) = Int64.add x (Int64.repr y)).
+ { intros; apply Int64.eqm_samerepr; auto using Int64.eqm_signed_unsigned with ints. }
+ assert (B: forall x y z, Int64.repr (Int64.signed x * y + z) = Int64.add (Int64.mul x (Int64.repr y)) (Int64.repr z)).
+ { intros; apply Int64.eqm_samerepr; apply Int64.eqm_add; auto with ints.
+ unfold Int64.mul; auto using Int64.eqm_signed_unsigned with ints. }
+ intros until res; intros VL EA.
+ unfold addr_strength_reduction_64_generic; destruct (addr_strength_reduction_64_generic_match addr args vl);
+ simpl in *; InvApproxRegs; SimplVM; try (inv EA).
+- econstructor; split; eauto. rewrite A, Val.addl_assoc, Val.addl_permut. auto.
+- econstructor; split; eauto. rewrite A, Val.addl_assoc. auto.
+- Local Transparent Val.addl.
+ econstructor; split; eauto. simpl. rewrite B. auto.
+- econstructor; split; eauto. rewrite A, Val.addl_permut. auto.
+- exists res; auto.
+Qed.
+
+Lemma addr_strength_reduction_64_correct:
+ forall addr args vl res,
+ vl = map (fun r => AE.get r ae) args ->
+ eval_addressing64 ge (Vptr sp Ptrofs.zero) addr e##args = Some res ->
+ let (addr', args') := addr_strength_reduction_64 addr args vl in
+ exists res', eval_addressing64 ge (Vptr sp Ptrofs.zero) addr' e##args' = Some res' /\ Val.lessdef res res'.
+Proof.
+ intros until res; intros VL EA. unfold addr_strength_reduction_64.
+ destruct (negb Archi.ptr64) eqn:SF. apply addr_strength_reduction_64_generic_correct; auto.
+ rewrite negb_false_iff in SF.
+ assert (A: forall n, Ptrofs.of_int64 (Int64.repr n) = Ptrofs.repr n) by auto with ptrofs.
+ assert (B: forall symb ofs n,
+ Genv.symbol_address ge symb (Ptrofs.add ofs (Ptrofs.repr n)) =
+ Val.addl (Genv.symbol_address ge symb ofs) (Vlong (Int64.repr n))).
+ { intros. rewrite <- A. apply Genv.shift_symbol_address_64; auto. }
+Local Opaque Val.addl.
+ destruct (addr_strength_reduction_64_match addr args vl);
+ simpl in *; InvApproxRegs; SimplVM; FuncInv; subst; rewrite ?SF.
+- econstructor; split; eauto. rewrite B. apply Val.addl_lessdef; auto.
+- econstructor; split; eauto. rewrite Ptrofs.add_zero_l.
+Local Transparent Val.addl.
+ inv H0; auto. rewrite H2. simpl; rewrite SF, A. auto.
+- econstructor; split; eauto.
+ unfold Ptrofs.add at 2. rewrite B.
+ fold (Ptrofs.add n1 (Ptrofs.of_int64 n2)).
+ rewrite Genv.shift_symbol_address_64 by auto.
+ rewrite ! Val.addl_assoc. apply Val.addl_lessdef; auto.
+- econstructor; split; eauto.
+ unfold Ptrofs.add at 2. rewrite B.
+ fold (Ptrofs.add n2 (Ptrofs.of_int64 n1)).
+ rewrite Genv.shift_symbol_address_64 by auto.
+ rewrite ! Val.addl_assoc. rewrite Val.addl_permut. apply Val.addl_lessdef; auto.
+- econstructor; split; eauto. rewrite Ptrofs.add_zero_l. rewrite Val.addl_assoc.
+ eapply Val.lessdef_trans. apply Val.addl_lessdef; eauto.
+ simpl. rewrite SF. rewrite Ptrofs.add_assoc. apply Val.lessdef_same; do 3 f_equal. auto with ptrofs.
+- econstructor; split; eauto. rewrite Ptrofs.add_zero_l. rewrite Val.addl_assoc, Val.addl_permut.
+ eapply Val.lessdef_trans. apply Val.addl_lessdef; eauto.
+ simpl. rewrite SF. rewrite <- (Ptrofs.add_commut n2). rewrite Ptrofs.add_assoc.
+ apply Val.lessdef_same; do 3 f_equal. auto with ptrofs.
+- econstructor; split; eauto. rewrite B. rewrite Genv.shift_symbol_address_64 by auto.
+ rewrite ! Val.addl_assoc. apply Val.addl_lessdef; auto.
+- apply addr_strength_reduction_64_generic_correct; auto.
+Qed.
+
+Lemma addr_strength_reduction_correct:
+ forall addr args vl res,
+ vl = map (fun r => AE.get r ae) args ->
+ eval_addressing ge (Vptr sp Ptrofs.zero) addr e##args = Some res ->
+ let (addr', args') := addr_strength_reduction addr args vl in
+ exists res', eval_addressing ge (Vptr sp Ptrofs.zero) addr' e##args' = Some res' /\ Val.lessdef res res'.
+Proof.
+ unfold eval_addressing, addr_strength_reduction. destruct Archi.ptr64.
+ apply addr_strength_reduction_64_correct.
+ apply addr_strength_reduction_32_correct.
+Qed.
+
+Lemma make_cmp_base_correct:
+ forall c args vl,
+ vl = map (fun r => AE.get r ae) args ->
+ let (op', args') := make_cmp_base c args vl in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some v
+ /\ Val.lessdef (Val.of_optbool (eval_condition c e##args m)) v.
+Proof.
+ intros. unfold make_cmp_base.
+ generalize (cond_strength_reduction_correct c args vl H).
+ destruct (cond_strength_reduction c args vl) as [c' args']. intros EQ.
+ econstructor; split. simpl; eauto. rewrite EQ. auto.
+Qed.
+
+Lemma make_cmp_correct:
+ forall c args vl,
+ vl = map (fun r => AE.get r ae) args ->
+ let (op', args') := make_cmp c args vl in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some v
+ /\ Val.lessdef (Val.of_optbool (eval_condition c e##args m)) v.
+Proof.
+ intros c args vl.
+ assert (Y: forall r, vincl (AE.get r ae) (Uns Ptop 1) = true ->
+ e#r = Vundef \/ e#r = Vint Int.zero \/ e#r = Vint Int.one).
+ { intros. apply vmatch_Uns_1 with bc Ptop. eapply vmatch_ge. eapply vincl_ge; eauto. apply MATCH. }
+ unfold make_cmp. case (make_cmp_match c args vl); intros.
+- destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1.
+ simpl in H; inv H. InvBooleans. subst n.
+ exists (e#r1); split; auto. simpl.
+ exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto.
+ destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0.
+ simpl in H; inv H. InvBooleans. subst n.
+ exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl.
+ exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto.
+ apply make_cmp_base_correct; auto.
+- destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0.
+ simpl in H; inv H. InvBooleans. subst n.
+ exists (e#r1); split; auto. simpl.
+ exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto.
+ destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1.
+ simpl in H; inv H. InvBooleans. subst n.
+ exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl.
+ exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto.
+ apply make_cmp_base_correct; auto.
+- apply make_cmp_base_correct; auto.
+Qed.
+
+Lemma make_addimm_correct:
+ forall n r,
+ let (op, args) := make_addimm n r in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.add e#r (Vint n)) v.
+Proof.
+ intros. unfold make_addimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; intros.
+ subst. exists (e#r); split; auto.
+ destruct (e#r); simpl; auto; rewrite ?Int.add_zero, ?Ptrofs.add_zero; auto.
+ exists (Val.add e#r (Vint n)); split; auto. simpl. rewrite Int.repr_signed; auto.
+Qed.
+
+Lemma make_shlimm_correct:
+ forall n r1 r2,
+ e#r2 = Vint n ->
+ let (op, args) := make_shlimm n r1 r2 in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shl e#r1 (Vint n)) v.
+Proof.
+ intros; unfold make_shlimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
+ exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shl_zero. auto.
+ destruct (Int.ltu n Int.iwordsize).
+ econstructor; split. simpl. eauto. auto.
+ econstructor; split. simpl. eauto. rewrite H; auto.
+Qed.
+
+Lemma make_shrimm_correct:
+ forall n r1 r2,
+ e#r2 = Vint n ->
+ let (op, args) := make_shrimm n r1 r2 in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shr e#r1 (Vint n)) v.
+Proof.
+ intros; unfold make_shrimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
+ exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shr_zero. auto.
+ destruct (Int.ltu n Int.iwordsize).
+ econstructor; split. simpl. eauto. auto.
+ econstructor; split. simpl. eauto. rewrite H; auto.
+Qed.
+
+Lemma make_shruimm_correct:
+ forall n r1 r2,
+ e#r2 = Vint n ->
+ let (op, args) := make_shruimm n r1 r2 in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shru e#r1 (Vint n)) v.
+Proof.
+ intros; unfold make_shruimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
+ exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shru_zero. auto.
+ destruct (Int.ltu n Int.iwordsize).
+ econstructor; split. simpl. eauto. auto.
+ econstructor; split. simpl. eauto. rewrite H; auto.
+Qed.
+
+Lemma make_mulimm_correct:
+ forall n r1,
+ let (op, args) := make_mulimm n r1 in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mul e#r1 (Vint n)) v.
+Proof.
+ intros; unfold make_mulimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
+ exists (Vint Int.zero); split; auto. destruct (e#r1); simpl; auto. rewrite Int.mul_zero; auto.
+ predSpec Int.eq Int.eq_spec n Int.one; intros. subst.
+ exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.mul_one; auto.
+ destruct (Int.is_power2 n) eqn:?; intros.
+ rewrite (Val.mul_pow2 e#r1 _ _ Heqo). econstructor; split. simpl; eauto. auto.
+ econstructor; split; eauto. auto.
+Qed.
+
+Lemma make_divimm_correct:
+ forall n r1 r2 v,
+ Val.divs e#r1 e#r2 = Some v ->
+ e#r2 = Vint n ->
+ let (op, args) := make_divimm n r1 r2 in
+ exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w.
+Proof.
+ intros; unfold make_divimm.
+ destruct (Int.is_power2 n) eqn:?.
+ destruct (Int.ltu i (Int.repr 31)) eqn:?.
+ exists v; split; auto. simpl. eapply Val.divs_pow2; eauto. congruence.
+ exists v; auto.
+ exists v; auto.
+Qed.
+
+Lemma make_divuimm_correct:
+ forall n r1 r2 v,
+ Val.divu e#r1 e#r2 = Some v ->
+ e#r2 = Vint n ->
+ let (op, args) := make_divuimm n r1 r2 in
+ exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w.
+Proof.
+ intros; unfold make_divuimm.
+ destruct (Int.is_power2 n) eqn:?.
+ econstructor; split. simpl; eauto.
+ rewrite H0 in H. erewrite Val.divu_pow2 by eauto. auto.
+ exists v; auto.
+Qed.
+
+Lemma make_moduimm_correct:
+ forall n r1 r2 v,
+ Val.modu e#r1 e#r2 = Some v ->
+ e#r2 = Vint n ->
+ let (op, args) := make_moduimm n r1 r2 in
+ exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w.
+Proof.
+ intros; unfold make_moduimm.
+ destruct (Int.is_power2 n) eqn:?.
+ exists v; split; auto. simpl. decEq. eapply Val.modu_pow2; eauto. congruence.
+ exists v; auto.
+Qed.
+
+Lemma make_andimm_correct:
+ forall n r x,
+ vmatch bc e#r x ->
+ let (op, args) := make_andimm n r x in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.and e#r (Vint n)) v.
+Proof.
+ intros; unfold make_andimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; intros.
+ subst n. exists (Vint Int.zero); split; auto. destruct (e#r); simpl; auto. rewrite Int.and_zero; auto.
+ predSpec Int.eq Int.eq_spec n Int.mone; intros.
+ subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.and_mone; auto.
+ destruct (match x with Uns _ k => Int.eq (Int.zero_ext k (Int.not n)) Int.zero
+ | _ => false end) eqn:UNS.
+ destruct x; try congruence.
+ exists (e#r); split; auto.
+ inv H; auto. simpl. replace (Int.and i n) with i; auto.
+ generalize (Int.eq_spec (Int.zero_ext n0 (Int.not n)) Int.zero); rewrite UNS; intro EQ.
+ Int.bit_solve. destruct (zlt i0 n0).
+ replace (Int.testbit n i0) with (negb (Int.testbit Int.zero i0)).
+ rewrite Int.bits_zero. simpl. rewrite andb_true_r. auto.
+ rewrite <- EQ. rewrite Int.bits_zero_ext by omega. rewrite zlt_true by auto.
+ rewrite Int.bits_not by auto. apply negb_involutive.
+ rewrite H6 by auto. auto.
+ econstructor; split; eauto. auto.
+Qed.
+
+Lemma make_orimm_correct:
+ forall n r,
+ let (op, args) := make_orimm n r in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.or e#r (Vint n)) v.
+Proof.
+ intros; unfold make_orimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; intros.
+ subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.or_zero; auto.
+ predSpec Int.eq Int.eq_spec n Int.mone; intros.
+ subst n. exists (Vint Int.mone); split; auto. destruct (e#r); simpl; auto. rewrite Int.or_mone; auto.
+ econstructor; split; eauto. auto.
+Qed.
+
+Lemma make_xorimm_correct:
+ forall n r,
+ let (op, args) := make_xorimm n r in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.xor e#r (Vint n)) v.
+Proof.
+ intros; unfold make_xorimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; intros.
+ subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.xor_zero; auto.
+ predSpec Int.eq Int.eq_spec n Int.mone; intros.
+ subst n. exists (Val.notint e#r); split; auto.
+ econstructor; split; eauto. auto.
+Qed.
+
+Lemma make_addlimm_correct:
+ forall n r,
+ let (op, args) := make_addlimm n r in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.addl e#r (Vlong n)) v.
+Proof.
+ intros. unfold make_addlimm.
+ predSpec Int64.eq Int64.eq_spec n Int64.zero; intros.
+ subst. exists (e#r); split; auto.
+ destruct (e#r); simpl; auto; rewrite ? Int64.add_zero, ? Ptrofs.add_zero; auto.
+ exists (Val.addl e#r (Vlong n)); split; auto. simpl. rewrite Int64.repr_signed; auto.
+Qed.
+
+Lemma make_shllimm_correct:
+ forall n r1 r2,
+ e#r2 = Vint n ->
+ let (op, args) := make_shllimm n r1 r2 in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shll e#r1 (Vint n)) v.
+Proof.
+ intros; unfold make_shllimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
+ exists (e#r1); split; auto. destruct (e#r1); simpl; auto.
+ unfold Int64.shl'. rewrite Z.shiftl_0_r, Int64.repr_unsigned. auto.
+ destruct (Int.ltu n Int64.iwordsize').
+ econstructor; split. simpl. eauto. auto.
+ econstructor; split. simpl. eauto. rewrite H; auto.
+Qed.
+
+Lemma make_shrlimm_correct:
+ forall n r1 r2,
+ e#r2 = Vint n ->
+ let (op, args) := make_shrlimm n r1 r2 in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shrl e#r1 (Vint n)) v.
+Proof.
+ intros; unfold make_shrlimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
+ exists (e#r1); split; auto. destruct (e#r1); simpl; auto.
+ unfold Int64.shr'. rewrite Z.shiftr_0_r, Int64.repr_signed. auto.
+ destruct (Int.ltu n Int64.iwordsize').
+ econstructor; split. simpl. eauto. auto.
+ econstructor; split. simpl. eauto. rewrite H; auto.
+Qed.
+
+Lemma make_shrluimm_correct:
+ forall n r1 r2,
+ e#r2 = Vint n ->
+ let (op, args) := make_shrluimm n r1 r2 in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shrlu e#r1 (Vint n)) v.
+Proof.
+ intros; unfold make_shrluimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
+ exists (e#r1); split; auto. destruct (e#r1); simpl; auto.
+ unfold Int64.shru'. rewrite Z.shiftr_0_r, Int64.repr_unsigned. auto.
+ destruct (Int.ltu n Int64.iwordsize').
+ econstructor; split. simpl. eauto. auto.
+ econstructor; split. simpl. eauto. rewrite H; auto.
+Qed.
+
+Lemma make_mullimm_correct:
+ forall n r1,
+ let (op, args) := make_mullimm n r1 in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mull e#r1 (Vlong n)) v.
+Proof.
+ intros; unfold make_mullimm.
+ predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. subst.
+ exists (Vlong Int64.zero); split; auto. destruct (e#r1); simpl; auto. rewrite Int64.mul_zero; auto.
+ predSpec Int64.eq Int64.eq_spec n Int64.one; intros. subst.
+ exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int64.mul_one; auto.
+ destruct (Int64.is_power2' n) eqn:?; intros.
+ exists (Val.shll e#r1 (Vint i)); split; auto.
+ destruct (e#r1); simpl; auto.
+ erewrite Int64.is_power2'_range by eauto.
+ erewrite Int64.mul_pow2' by eauto. auto.
+ econstructor; split; eauto. auto.
+Qed.
+
+Lemma make_divlimm_correct:
+ forall n r1 r2 v,
+ Val.divls e#r1 e#r2 = Some v ->
+ e#r2 = Vlong n ->
+ let (op, args) := make_divlimm n r1 r2 in
+ exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w.
+Proof.
+ intros; unfold make_divlimm.
+ destruct (Int64.is_power2' n) eqn:?. destruct (Int.ltu i (Int.repr 63)) eqn:?.
+ rewrite H0 in H. econstructor; split. simpl; eauto. eapply Val.divls_pow2; eauto. auto.
+ exists v; auto.
+ exists v; auto.
+Qed.
+
+Lemma make_divluimm_correct:
+ forall n r1 r2 v,
+ Val.divlu e#r1 e#r2 = Some v ->
+ e#r2 = Vlong n ->
+ let (op, args) := make_divluimm n r1 r2 in
+ exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w.
+Proof.
+ intros; unfold make_divluimm.
+ destruct (Int64.is_power2' n) eqn:?.
+ econstructor; split. simpl; eauto.
+ rewrite H0 in H. destruct (e#r1); inv H. destruct (Int64.eq n Int64.zero); inv H2.
+ simpl.
+ erewrite Int64.is_power2'_range by eauto.
+ erewrite Int64.divu_pow2' by eauto. auto.
+ exists v; auto.
+Qed.
+
+Lemma make_modluimm_correct:
+ forall n r1 r2 v,
+ Val.modlu e#r1 e#r2 = Some v ->
+ e#r2 = Vlong n ->
+ let (op, args) := make_modluimm n r1 r2 in
+ exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w.
+Proof.
+ intros; unfold make_modluimm.
+ destruct (Int64.is_power2 n) eqn:?.
+ exists v; split; auto. simpl. decEq.
+ rewrite H0 in H. destruct (e#r1); inv H. destruct (Int64.eq n Int64.zero); inv H2.
+ simpl. erewrite Int64.modu_and by eauto. auto.
+ exists v; auto.
+Qed.
+
+Lemma make_andlimm_correct:
+ forall n r x,
+ let (op, args) := make_andlimm n r x in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.andl e#r (Vlong n)) v.
+Proof.
+ intros; unfold make_andlimm.
+ predSpec Int64.eq Int64.eq_spec n Int64.zero; intros.
+ subst n. exists (Vlong Int64.zero); split; auto. destruct (e#r); simpl; auto. rewrite Int64.and_zero; auto.
+ predSpec Int64.eq Int64.eq_spec n Int64.mone; intros.
+ subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int64.and_mone; auto.
+ econstructor; split; eauto. auto.
+Qed.
+
+Lemma make_orlimm_correct:
+ forall n r,
+ let (op, args) := make_orlimm n r in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.orl e#r (Vlong n)) v.
+Proof.
+ intros; unfold make_orlimm.
+ predSpec Int64.eq Int64.eq_spec n Int64.zero; intros.
+ subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int64.or_zero; auto.
+ predSpec Int64.eq Int64.eq_spec n Int64.mone; intros.
+ subst n. exists (Vlong Int64.mone); split; auto. destruct (e#r); simpl; auto. rewrite Int64.or_mone; auto.
+ econstructor; split; eauto. auto.
+Qed.
+
+Lemma make_xorlimm_correct:
+ forall n r,
+ let (op, args) := make_xorlimm n r in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.xorl e#r (Vlong n)) v.
+Proof.
+ intros; unfold make_xorlimm.
+ predSpec Int64.eq Int64.eq_spec n Int64.zero; intros.
+ subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int64.xor_zero; auto.
+ predSpec Int64.eq Int64.eq_spec n Int64.mone; intros.
+ subst n. exists (Val.notl e#r); split; auto.
+ econstructor; split; eauto. auto.
+Qed.
+
+Lemma make_mulfimm_correct:
+ forall n r1 r2,
+ e#r2 = Vfloat n ->
+ let (op, args) := make_mulfimm n r1 r1 r2 in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulf e#r1 e#r2) v.
+Proof.
+ intros; unfold make_mulfimm.
+ destruct (Float.eq_dec n (Float.of_int (Int.repr 2))); intros.
+ simpl. econstructor; split. eauto. rewrite H; subst n.
+ destruct (e#r1); simpl; auto. rewrite Float.mul2_add; auto.
+ simpl. econstructor; split; eauto.
+Qed.
+
+Lemma make_mulfimm_correct_2:
+ forall n r1 r2,
+ e#r1 = Vfloat n ->
+ let (op, args) := make_mulfimm n r2 r1 r2 in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulf e#r1 e#r2) v.
+Proof.
+ intros; unfold make_mulfimm.
+ destruct (Float.eq_dec n (Float.of_int (Int.repr 2))); intros.
+ simpl. econstructor; split. eauto. rewrite H; subst n.
+ destruct (e#r2); simpl; auto. rewrite Float.mul2_add; auto.
+ rewrite Float.mul_commut; auto.
+ simpl. econstructor; split; eauto.
+Qed.
+
+Lemma make_mulfsimm_correct:
+ forall n r1 r2,
+ e#r2 = Vsingle n ->
+ let (op, args) := make_mulfsimm n r1 r1 r2 in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulfs e#r1 e#r2) v.
+Proof.
+ intros; unfold make_mulfsimm.
+ destruct (Float32.eq_dec n (Float32.of_int (Int.repr 2))); intros.
+ simpl. econstructor; split. eauto. rewrite H; subst n.
+ destruct (e#r1); simpl; auto. rewrite Float32.mul2_add; auto.
+ simpl. econstructor; split; eauto.
+Qed.
+
+Lemma make_mulfsimm_correct_2:
+ forall n r1 r2,
+ e#r1 = Vsingle n ->
+ let (op, args) := make_mulfsimm n r2 r1 r2 in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulfs e#r1 e#r2) v.
+Proof.
+ intros; unfold make_mulfsimm.
+ destruct (Float32.eq_dec n (Float32.of_int (Int.repr 2))); intros.
+ simpl. econstructor; split. eauto. rewrite H; subst n.
+ destruct (e#r2); simpl; auto. rewrite Float32.mul2_add; auto.
+ rewrite Float32.mul_commut; auto.
+ simpl. econstructor; split; eauto.
+Qed.
+
+Lemma make_cast8signed_correct:
+ forall r x,
+ vmatch bc e#r x ->
+ let (op, args) := make_cast8signed r x in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.sign_ext 8 e#r) v.
+Proof.
+ intros; unfold make_cast8signed. destruct (vincl x (Sgn Ptop 8)) eqn:INCL.
+ exists e#r; split; auto.
+ assert (V: vmatch bc e#r (Sgn Ptop 8)).
+ { eapply vmatch_ge; eauto. apply vincl_ge; auto. }
+ inv V; simpl; auto. rewrite is_sgn_sign_ext in H4 by auto. rewrite H4; auto.
+ econstructor; split; simpl; eauto.
+Qed.
+
+Lemma make_cast8unsigned_correct:
+ forall r x,
+ vmatch bc e#r x ->
+ let (op, args) := make_cast8unsigned r x in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.zero_ext 8 e#r) v.
+Proof.
+ intros; unfold make_cast8unsigned. destruct (vincl x (Uns Ptop 8)) eqn:INCL.
+ exists e#r; split; auto.
+ assert (V: vmatch bc e#r (Uns Ptop 8)).
+ { eapply vmatch_ge; eauto. apply vincl_ge; auto. }
+ inv V; simpl; auto. rewrite is_uns_zero_ext in H4 by auto. rewrite H4; auto.
+ econstructor; split; simpl; eauto.
+Qed.
+
+Lemma make_cast16signed_correct:
+ forall r x,
+ vmatch bc e#r x ->
+ let (op, args) := make_cast16signed r x in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.sign_ext 16 e#r) v.
+Proof.
+ intros; unfold make_cast16signed. destruct (vincl x (Sgn Ptop 16)) eqn:INCL.
+ exists e#r; split; auto.
+ assert (V: vmatch bc e#r (Sgn Ptop 16)).
+ { eapply vmatch_ge; eauto. apply vincl_ge; auto. }
+ inv V; simpl; auto. rewrite is_sgn_sign_ext in H4 by auto. rewrite H4; auto.
+ econstructor; split; simpl; eauto.
+Qed.
+
+Lemma make_cast16unsigned_correct:
+ forall r x,
+ vmatch bc e#r x ->
+ let (op, args) := make_cast16unsigned r x in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.zero_ext 16 e#r) v.
+Proof.
+ intros; unfold make_cast16unsigned. destruct (vincl x (Uns Ptop 16)) eqn:INCL.
+ exists e#r; split; auto.
+ assert (V: vmatch bc e#r (Uns Ptop 16)).
+ { eapply vmatch_ge; eauto. apply vincl_ge; auto. }
+ inv V; simpl; auto. rewrite is_uns_zero_ext in H4 by auto. rewrite H4; auto.
+ econstructor; split; simpl; eauto.
+Qed.
+
+Lemma op_strength_reduction_correct:
+ forall op args vl v,
+ vl = map (fun r => AE.get r ae) args ->
+ eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v ->
+ let (op', args') := op_strength_reduction op args vl in
+ exists w, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some w /\ Val.lessdef v w.
+Proof.
+ intros until v; unfold op_strength_reduction;
+ case (op_strength_reduction_match op args vl); simpl; intros.
+(* cast8signed *)
+ InvApproxRegs; SimplVM; inv H0. apply make_cast8signed_correct; auto.
+(* cast8unsigned *)
+ InvApproxRegs; SimplVM; inv H0. apply make_cast8unsigned_correct; auto.
+(* cast16signed *)
+ InvApproxRegs; SimplVM; inv H0. apply make_cast16signed_correct; auto.
+(* cast16unsigned *)
+ InvApproxRegs; SimplVM; inv H0. apply make_cast16unsigned_correct; auto.
+(* sub *)
+ InvApproxRegs; SimplVM; inv H0. rewrite Val.sub_add_opp. apply make_addimm_correct; auto.
+(* mul *)
+ rewrite Val.mul_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_mulimm_correct; auto.
+ InvApproxRegs; SimplVM; inv H0. apply make_mulimm_correct; auto.
+(* divs *)
+ assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto.
+ apply make_divimm_correct; auto.
+(* divu *)
+ assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto.
+ apply make_divuimm_correct; auto.
+(* modu *)
+ assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto.
+ apply make_moduimm_correct; auto.
+(* and *)
+ rewrite Val.and_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_andimm_correct; auto.
+ InvApproxRegs; SimplVM; inv H0. apply make_andimm_correct; auto.
+ inv H; inv H0. apply make_andimm_correct; auto.
+(* or *)
+ rewrite Val.or_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_orimm_correct; auto.
+ InvApproxRegs; SimplVM; inv H0. apply make_orimm_correct; auto.
+(* xor *)
+ rewrite Val.xor_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_xorimm_correct; auto.
+ InvApproxRegs; SimplVM; inv H0. apply make_xorimm_correct; auto.
+(* shl *)
+ InvApproxRegs; SimplVM; inv H0. apply make_shlimm_correct; auto.
+(* shr *)
+ InvApproxRegs; SimplVM; inv H0. apply make_shrimm_correct; auto.
+(* shru *)
+ InvApproxRegs; SimplVM; inv H0. apply make_shruimm_correct; auto.
+(* lea *)
+ exploit addr_strength_reduction_32_correct; eauto.
+ destruct (addr_strength_reduction_32 addr args0 vl0) as [addr' args'].
+ auto.
+(* subl *)
+ InvApproxRegs; SimplVM; inv H0.
+ replace (Val.subl e#r1 (Vlong n2)) with (Val.addl e#r1 (Vlong (Int64.neg n2))).
+ apply make_addlimm_correct; auto.
+ unfold Val.addl, Val.subl. destruct Archi.ptr64 eqn:SF, e#r1; auto.
+ rewrite Int64.sub_add_opp; auto.
+ rewrite Ptrofs.sub_add_opp. do 2 f_equal. auto with ptrofs.
+ rewrite Int64.sub_add_opp; auto.
+(* mull *)
+ rewrite Val.mull_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_mullimm_correct; auto.
+ InvApproxRegs; SimplVM; inv H0. apply make_mullimm_correct; auto.
+(* divl *)
+ assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto.
+ apply make_divlimm_correct; auto.
+(* divlu *)
+ assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto.
+ apply make_divluimm_correct; auto.
+(* modlu *)
+ assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto.
+ apply make_modluimm_correct; auto.
+(* andl *)
+ rewrite Val.andl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_andlimm_correct; auto.
+ InvApproxRegs; SimplVM; inv H0. apply make_andlimm_correct; auto.
+ inv H; inv H0. apply make_andlimm_correct; auto.
+(* orl *)
+ rewrite Val.orl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_orlimm_correct; auto.
+ InvApproxRegs; SimplVM; inv H0. apply make_orlimm_correct; auto.
+(* xorl *)
+ rewrite Val.xorl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_xorlimm_correct; auto.
+ InvApproxRegs; SimplVM; inv H0. apply make_xorlimm_correct; auto.
+(* shll *)
+ InvApproxRegs; SimplVM; inv H0. apply make_shllimm_correct; auto.
+(* shrl *)
+ InvApproxRegs; SimplVM; inv H0. apply make_shrlimm_correct; auto.
+(* shrlu *)
+ InvApproxRegs; SimplVM; inv H0. apply make_shrluimm_correct; auto.
+(* leal *)
+ exploit addr_strength_reduction_64_correct; eauto.
+ destruct (addr_strength_reduction_64 addr args0 vl0) as [addr' args'].
+ auto.
+(* cond *)
+ inv H0. apply make_cmp_correct; auto.
+(* mulf *)
+ InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfimm_correct; auto.
+ InvApproxRegs; SimplVM; inv H0. fold (Val.mulf (Vfloat n1) e#r2).
+ rewrite <- H2. apply make_mulfimm_correct_2; auto.
+(* mulfs *)
+ InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfsimm_correct; auto.
+ InvApproxRegs; SimplVM; inv H0. fold (Val.mulfs (Vsingle n1) e#r2).
+ rewrite <- H2. apply make_mulfsimm_correct_2; auto.
+(* default *)
+ exists v; auto.
+Qed.
+
+End STRENGTH_REDUCTION.
diff --git a/x86/Conventions1.v b/x86/Conventions1.v
new file mode 100644
index 00000000..dbc8b064
--- /dev/null
+++ b/x86/Conventions1.v
@@ -0,0 +1,473 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris *)
+(* *)
+(* 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 Decidableplus.
+Require Import AST Machregs Locations.
+
+(** * Classification of machine registers *)
+
+(** Machine registers (type [mreg] in module [Locations]) are divided in
+ the following groups:
+- 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 x86-32 and x86-64 application binary interfaces (ABI)
+ in our choice of callee- and caller-save registers.
+*)
+
+Definition is_callee_save (r: mreg) : bool :=
+ match r with
+ | AX | CX | DX => false
+ | BX | BP => true
+ | SI | DI => negb Archi.ptr64 (**r callee-save in 32 bits but not in 64 bits *)
+ | R8 | R9 | R10 | R11 => false
+ | R12 | R13 | R14 | R15 => true
+ | X0 | X1 | X2 | X3 | X4 | X5 | X6 | X7 => false
+ | X8 | X9 | X10 | X11 | X12 | X13 | X14 | X15 => false
+ | FP0 => false
+ end.
+
+Definition int_caller_save_regs :=
+ if Archi.ptr64
+ then AX :: CX :: DX :: SI :: DI :: R8 :: R9 :: R10 :: R11 :: nil
+ else AX :: CX :: DX :: nil.
+
+Definition float_caller_save_regs :=
+ if Archi.ptr64
+ then X0 :: X1 :: X2 :: X3 :: X4 :: X5 :: X6 :: X7 ::
+ X8 :: X9 :: X10 :: X11 :: X12 :: X13 :: X14 :: X15 :: nil
+ else X0 :: X1 :: X2 :: X3 :: X4 :: X5 :: X6 :: X7 :: nil.
+
+Definition int_callee_save_regs :=
+ if Archi.ptr64
+ then BX :: BP :: R12 :: R13 :: R14 :: R15 :: nil
+ else BX :: SI :: DI :: BP :: nil.
+
+Definition float_callee_save_regs : list mreg := nil.
+
+Definition destroyed_at_call :=
+ List.filter (fun r => negb (is_callee_save r)) all_mregs.
+
+Definition dummy_int_reg := AX. (**r Used in [Regalloc]. *)
+Definition dummy_float_reg := X0. (**r Used in [Regalloc]. *)
+
+Definition is_float_reg (r: mreg) :=
+ match r with
+ | AX | BX | CX | DX | SI | DI | BP
+ | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15 => false
+ | X0 | X1 | X2 | X3 | X4 | X5 | X6 | X7
+ | X8 | X9 | X10 | X11 | X12 | X13 | X14 | X15 | FP0 => true
+ end.
+
+(** * 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 compiler, we
+ implement the standard x86-32 and x86-64 conventions. *)
+
+(** ** Location of function result *)
+
+(** In 32 bit mode, the result value of a function is passed back to the
+ caller in registers [AX] or [DX:AX] or [FP0], depending on the type
+ of the returned value. We treat a function without result as a
+ function with one integer result. *)
+
+Definition loc_result_32 (s: signature) : rpair mreg :=
+ match s.(sig_res) with
+ | None => One AX
+ | Some (Tint | Tany32) => One AX
+ | Some (Tfloat | Tsingle) => One FP0
+ | Some Tany64 => One X0
+ | Some Tlong => Twolong DX AX
+ end.
+
+(** In 64 bit mode, he result value of a function is passed back to
+ the caller in registers [AX] or [X0]. *)
+
+Definition loc_result_64 (s: signature) : rpair mreg :=
+ match s.(sig_res) with
+ | None => One AX
+ | Some (Tint | Tlong | Tany32 | Tany64) => One AX
+ | Some (Tfloat | Tsingle) => One X0
+ end.
+
+Definition loc_result :=
+ if Archi.ptr64 then loc_result_64 else loc_result_32.
+
+(** The result registers have types compatible with that given in the signature. *)
+
+Lemma loc_result_type:
+ forall sig,
+ subtype (proj_sig_res sig) (typ_rpair mreg_type (loc_result sig)) = true.
+Proof.
+ intros. unfold proj_sig_res, loc_result, loc_result_32, loc_result_64, mreg_type;
+ destruct Archi.ptr64; destruct (sig_res sig) as [[]|]; auto.
+Qed.
+
+(** The result locations are caller-save registers *)
+
+Lemma loc_result_caller_save:
+ forall (s: signature),
+ forall_rpair (fun r => is_callee_save r = false) (loc_result s).
+Proof.
+ intros. unfold loc_result, loc_result_32, loc_result_64, is_callee_save;
+ destruct Archi.ptr64; destruct (sig_res s) as [[]|]; simpl; auto.
+Qed.
+
+(** If the result is in a pair of registers, those registers are distinct and have type [Tint] at least. *)
+
+Lemma loc_result_pair:
+ forall sg,
+ match loc_result sg with
+ | One _ => True
+ | Twolong r1 r2 =>
+ r1 <> r2 /\ sg.(sig_res) = Some Tlong
+ /\ subtype Tint (mreg_type r1) = true /\ subtype Tint (mreg_type r2) = true
+ /\ Archi.splitlong = true
+ end.
+Proof.
+ intros. change Archi.splitlong with (negb Archi.ptr64).
+ unfold loc_result, loc_result_32, loc_result_64, mreg_type;
+ destruct Archi.ptr64; destruct (sig_res sg) as [[]|]; auto.
+ split; auto. congruence.
+Qed.
+
+(** The location of the result depends only on the result part of the signature *)
+
+Lemma loc_result_exten:
+ forall s1 s2, s1.(sig_res) = s2.(sig_res) -> loc_result s1 = loc_result s2.
+Proof.
+ intros. unfold loc_result, loc_result_32, loc_result_64.
+ destruct Archi.ptr64; rewrite H; auto.
+Qed.
+
+(** ** Location of function arguments *)
+
+(** In the x86-32 ABI, all arguments are passed on stack. (Snif.) *)
+
+Fixpoint loc_arguments_32
+ (tyl: list typ) (ofs: Z) {struct tyl} : list (rpair loc) :=
+ match tyl with
+ | nil => nil
+ | ty :: tys =>
+ match ty with
+ | Tlong => Twolong (S Outgoing (ofs + 1) Tint) (S Outgoing ofs Tint)
+ | _ => One (S Outgoing ofs ty)
+ end
+ :: loc_arguments_32 tys (ofs + typesize ty)
+ end.
+
+(** In the x86-64 ABI:
+- The first 6 integer arguments are passed in registers [DI], [SI], [DX], [CX], [R8], [R9].
+- The first 8 floating-point arguments are passed in registers [X0] to [X7].
+- Extra arguments are passed on the stack, in [Outgoing] slots.
+ Consecutive stack slots are separated by 8 bytes, even if only 4 bytes
+ of data is used in a slot.
+*)
+
+Definition int_param_regs := DI :: SI :: DX :: CX :: R8 :: R9 :: nil.
+Definition float_param_regs := X0 :: X1 :: X2 :: X3 :: X4 :: X5 :: X6 :: X7 :: nil.
+
+Fixpoint loc_arguments_64
+ (tyl: list typ) (ir fr ofs: Z) {struct tyl} : list (rpair loc) :=
+ match tyl with
+ | nil => nil
+ | (Tint | Tlong | Tany32 | Tany64) as ty :: tys =>
+ match list_nth_z int_param_regs ir with
+ | None =>
+ One (S Outgoing ofs ty) :: loc_arguments_64 tys ir fr (ofs + 2)
+ | Some ireg =>
+ One (R ireg) :: loc_arguments_64 tys (ir + 1) fr ofs
+ end
+ | (Tfloat | Tsingle) as ty :: tys =>
+ match list_nth_z float_param_regs fr with
+ | None =>
+ One (S Outgoing ofs ty) :: loc_arguments_64 tys ir fr (ofs + 2)
+ | Some freg =>
+ One (R freg) :: loc_arguments_64 tys ir (fr + 1) ofs
+ end
+ end.
+
+(** [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 (rpair loc) :=
+ if Archi.ptr64
+ then loc_arguments_64 s.(sig_args) 0 0 0
+ else loc_arguments_32 s.(sig_args) 0.
+
+(** [size_arguments s] returns the number of [Outgoing] slots used
+ to call a function with signature [s]. *)
+
+Fixpoint size_arguments_32
+ (tyl: list typ) (ofs: Z) {struct tyl} : Z :=
+ match tyl with
+ | nil => ofs
+ | ty :: tys => size_arguments_32 tys (ofs + typesize ty)
+ end.
+
+Fixpoint size_arguments_64 (tyl: list typ) (ir fr ofs: Z) {struct tyl} : Z :=
+ match tyl with
+ | nil => ofs
+ | (Tint | Tlong | Tany32 | Tany64) :: tys =>
+ match list_nth_z int_param_regs ir with
+ | None => size_arguments_64 tys ir fr (ofs + 2)
+ | Some ireg => size_arguments_64 tys (ir + 1) fr ofs
+ end
+ | (Tfloat | Tsingle) :: tys =>
+ match list_nth_z float_param_regs fr with
+ | None => size_arguments_64 tys ir fr (ofs + 2)
+ | Some freg => size_arguments_64 tys ir (fr + 1) ofs
+ end
+ end.
+
+Definition size_arguments (s: signature) : Z :=
+ if Archi.ptr64
+ then size_arguments_64 s.(sig_args) 0 0 0
+ else size_arguments_32 s.(sig_args) 0.
+
+(** Argument locations are either caller-save registers or [Outgoing]
+ stack slots at nonnegative offsets. *)
+
+Definition loc_argument_acceptable (l: loc) : Prop :=
+ match l with
+ | R r => is_callee_save r = false
+ | S Outgoing ofs ty => ofs >= 0 /\ (typealign ty | ofs)
+ | _ => False
+ end.
+
+Definition loc_argument_32_charact (ofs: Z) (l: loc) : Prop :=
+ match l with
+ | S Outgoing ofs' ty => ofs' >= ofs /\ typealign ty = 1
+ | _ => False
+ end.
+
+Definition loc_argument_64_charact (ofs: Z) (l: loc) : Prop :=
+ match l with
+ | R r => In r int_param_regs \/ In r float_param_regs
+ | S Outgoing ofs' ty => ofs' >= ofs /\ (2 | ofs')
+ | _ => False
+ end.
+
+Remark loc_arguments_32_charact:
+ forall tyl ofs p,
+ In p (loc_arguments_32 tyl ofs) -> forall_rpair (loc_argument_32_charact ofs) p.
+Proof.
+ assert (X: forall ofs1 ofs2 l, loc_argument_32_charact ofs2 l -> ofs1 <= ofs2 -> loc_argument_32_charact ofs1 l).
+ { destruct l; simpl; intros; auto. destruct sl; auto. intuition omega. }
+ induction tyl as [ | ty tyl]; simpl loc_arguments_32; intros.
+- contradiction.
+- destruct H.
++ destruct ty; subst p; simpl; omega.
++ apply IHtyl in H. generalize (typesize_pos ty); intros. destruct p; simpl in *.
+* eapply X; eauto; omega.
+* destruct H; split; eapply X; eauto; omega.
+Qed.
+
+Remark loc_arguments_64_charact:
+ forall tyl ir fr ofs p,
+ In p (loc_arguments_64 tyl ir fr ofs) -> (2 | ofs) -> forall_rpair (loc_argument_64_charact ofs) p.
+Proof.
+ assert (X: forall ofs1 ofs2 l, loc_argument_64_charact ofs2 l -> ofs1 <= ofs2 -> loc_argument_64_charact ofs1 l).
+ { destruct l; simpl; intros; auto. destruct sl; auto. intuition omega. }
+ assert (Y: forall ofs1 ofs2 p, forall_rpair (loc_argument_64_charact ofs2) p -> ofs1 <= ofs2 -> forall_rpair (loc_argument_64_charact ofs1) p).
+ { destruct p; simpl; intuition eauto. }
+ assert (Z: forall ofs, (2 | ofs) -> (2 | ofs + 2)).
+ { intros. apply Z.divide_add_r; auto. apply Zdivide_refl. }
+Opaque list_nth_z.
+ induction tyl; simpl loc_arguments_64; intros.
+ elim H.
+ assert (A: forall ty, In p
+ match list_nth_z int_param_regs ir with
+ | Some ireg => One (R ireg) :: loc_arguments_64 tyl (ir + 1) fr ofs
+ | None => One (S Outgoing ofs ty) :: loc_arguments_64 tyl ir fr (ofs + 2)
+ end ->
+ forall_rpair (loc_argument_64_charact ofs) p).
+ { intros. destruct (list_nth_z int_param_regs ir) as [r|] eqn:E; destruct H1.
+ subst. left. eapply list_nth_z_in; eauto.
+ eapply IHtyl; eauto.
+ subst. split. omega. assumption.
+ eapply Y; eauto. omega. }
+ assert (B: forall ty, In p
+ match list_nth_z float_param_regs fr with
+ | Some ireg => One (R ireg) :: loc_arguments_64 tyl ir (fr + 1) ofs
+ | None => One (S Outgoing ofs ty) :: loc_arguments_64 tyl ir fr (ofs + 2)
+ end ->
+ forall_rpair (loc_argument_64_charact ofs) p).
+ { intros. destruct (list_nth_z float_param_regs fr) as [r|] eqn:E; destruct H1.
+ subst. right. eapply list_nth_z_in; eauto.
+ eapply IHtyl; eauto.
+ subst. split. omega. assumption.
+ eapply Y; eauto. omega. }
+ destruct a; eauto.
+Qed.
+
+Lemma loc_arguments_acceptable:
+ forall (s: signature) (p: rpair loc),
+ In p (loc_arguments s) -> forall_rpair loc_argument_acceptable p.
+Proof.
+ unfold loc_arguments; intros. destruct Archi.ptr64 eqn:SF.
+- (* 64 bits *)
+ assert (A: forall r, In r int_param_regs -> is_callee_save r = false) by (unfold is_callee_save; rewrite SF; decide_goal).
+ assert (B: forall r, In r float_param_regs -> is_callee_save r = false) by decide_goal.
+ assert (X: forall l, loc_argument_64_charact 0 l -> loc_argument_acceptable l).
+ { unfold loc_argument_64_charact, loc_argument_acceptable.
+ destruct l as [r | [] ofs ty]; auto. intros [C|C]; auto.
+ intros [C D]. split; auto. apply Zdivide_trans with 2; auto.
+ exists (2 / typealign ty); destruct ty; reflexivity.
+ }
+ exploit loc_arguments_64_charact; eauto using Zdivide_0.
+ unfold forall_rpair; destruct p; intuition auto.
+- (* 32 bits *)
+ assert (X: forall l, loc_argument_32_charact 0 l -> loc_argument_acceptable l).
+ { destruct l as [r | [] ofs ty]; simpl; intuition auto. rewrite H2; apply Z.divide_1_l. }
+ exploit loc_arguments_32_charact; eauto.
+ unfold forall_rpair; destruct p; intuition auto.
+Qed.
+
+Hint Resolve loc_arguments_acceptable: locs.
+
+(** The offsets of [Outgoing] arguments are below [size_arguments s]. *)
+
+Remark size_arguments_32_above:
+ forall tyl ofs0, ofs0 <= size_arguments_32 tyl ofs0.
+Proof.
+ induction tyl; simpl; intros.
+ omega.
+ apply Zle_trans with (ofs0 + typesize a); auto.
+ generalize (typesize_pos a); omega.
+Qed.
+
+Remark size_arguments_64_above:
+ forall tyl ir fr ofs0,
+ ofs0 <= size_arguments_64 tyl ir fr ofs0.
+Proof.
+ induction tyl; simpl; intros.
+ omega.
+ assert (A: ofs0 <=
+ match list_nth_z int_param_regs ir with
+ | Some _ => size_arguments_64 tyl (ir + 1) fr ofs0
+ | None => size_arguments_64 tyl ir fr (ofs0 + 2)
+ end).
+ { destruct (list_nth_z int_param_regs ir); eauto.
+ apply Zle_trans with (ofs0 + 2); auto. omega. }
+ assert (B: ofs0 <=
+ match list_nth_z float_param_regs fr with
+ | Some _ => size_arguments_64 tyl ir (fr + 1) ofs0
+ | None => size_arguments_64 tyl ir fr (ofs0 + 2)
+ end).
+ { destruct (list_nth_z float_param_regs fr); eauto.
+ apply Zle_trans with (ofs0 + 2); auto. omega. }
+ destruct a; auto.
+Qed.
+
+Lemma size_arguments_above:
+ forall s, size_arguments s >= 0.
+Proof.
+ intros; unfold size_arguments. apply Zle_ge.
+ destruct Archi.ptr64; [apply size_arguments_64_above|apply size_arguments_32_above].
+Qed.
+
+Lemma loc_arguments_32_bounded:
+ forall ofs ty tyl ofs0,
+ In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments_32 tyl ofs0)) ->
+ ofs + typesize ty <= size_arguments_32 tyl ofs0.
+Proof.
+ induction tyl as [ | t l]; simpl; intros x IN.
+- contradiction.
+- rewrite in_app_iff in IN; destruct IN as [IN|IN].
++ apply Zle_trans with (x + typesize t); [|apply size_arguments_32_above].
+ Ltac decomp :=
+ match goal with
+ | [ H: _ \/ _ |- _ ] => destruct H; decomp
+ | [ H: S _ _ _ = S _ _ _ |- _ ] => inv H
+ | [ H: False |- _ ] => contradiction
+ end.
+ destruct t; simpl in IN; decomp; simpl; omega.
++ apply IHl; auto.
+Qed.
+
+Lemma loc_arguments_64_bounded:
+ forall ofs ty tyl ir fr ofs0,
+ In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments_64 tyl ir fr ofs0)) ->
+ ofs + typesize ty <= size_arguments_64 tyl ir fr ofs0.
+Proof.
+ induction tyl; simpl; intros.
+ contradiction.
+ assert (T: forall ty0, typesize ty0 <= 2).
+ { destruct ty0; simpl; omega. }
+ assert (A: forall ty0,
+ In (S Outgoing ofs ty) (regs_of_rpairs
+ match list_nth_z int_param_regs ir with
+ | Some ireg =>
+ One (R ireg) :: loc_arguments_64 tyl (ir + 1) fr ofs0
+ | None => One (S Outgoing ofs0 ty0) :: loc_arguments_64 tyl ir fr (ofs0 + 2)
+ end) ->
+ ofs + typesize ty <=
+ match list_nth_z int_param_regs ir with
+ | Some _ => size_arguments_64 tyl (ir + 1) fr ofs0
+ | None => size_arguments_64 tyl ir fr (ofs0 + 2)
+ end).
+ { intros. destruct (list_nth_z int_param_regs ir); simpl in H0; destruct H0.
+ - discriminate.
+ - eapply IHtyl; eauto.
+ - inv H0. apply Zle_trans with (ofs + 2). specialize (T ty). omega. apply size_arguments_64_above.
+ - eapply IHtyl; eauto. }
+ assert (B: forall ty0,
+ In (S Outgoing ofs ty) (regs_of_rpairs
+ match list_nth_z float_param_regs fr with
+ | Some ireg =>
+ One (R ireg) :: loc_arguments_64 tyl ir (fr + 1) ofs0
+ | None => One (S Outgoing ofs0 ty0) :: loc_arguments_64 tyl ir fr (ofs0 + 2)
+ end) ->
+ ofs + typesize ty <=
+ match list_nth_z float_param_regs fr with
+ | Some _ => size_arguments_64 tyl ir (fr + 1) ofs0
+ | None => size_arguments_64 tyl ir fr (ofs0 + 2)
+ end).
+ { intros. destruct (list_nth_z float_param_regs fr); simpl in H0; destruct H0.
+ - discriminate.
+ - eapply IHtyl; eauto.
+ - inv H0. apply Zle_trans with (ofs + 2). specialize (T ty). omega. apply size_arguments_64_above.
+ - eapply IHtyl; eauto. }
+ destruct a; eauto.
+Qed.
+
+Lemma loc_arguments_bounded:
+ forall (s: signature) (ofs: Z) (ty: typ),
+ In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments s)) ->
+ ofs + typesize ty <= size_arguments s.
+Proof.
+ unfold loc_arguments, size_arguments; intros.
+ destruct Archi.ptr64; eauto using loc_arguments_32_bounded, loc_arguments_64_bounded.
+Qed.
+
+Lemma loc_arguments_main:
+ loc_arguments signature_main = nil.
+Proof.
+ unfold loc_arguments; destruct Archi.ptr64; reflexivity.
+Qed.
diff --git a/x86/Machregs.v b/x86/Machregs.v
new file mode 100644
index 00000000..741081a6
--- /dev/null
+++ b/x86/Machregs.v
@@ -0,0 +1,367 @@
+(* *********************************************************************)
+(* *)
+(* 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 String.
+Require Import Coqlib.
+Require Import Decidableplus.
+Require Import Maps.
+Require Import AST.
+Require Import Integers.
+Require Import Op.
+
+(** ** 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.
+- Floating-point registers that can be allocated to RTL pseudo-registers.
+- The special [FP0] register denoting the top of the X87 float stack.
+
+ The type [mreg] does not include special-purpose or reserved
+ machine registers such as the stack pointer and the condition codes. *)
+
+Inductive mreg: Type :=
+ (** Allocatable integer regs *)
+ | AX | BX | CX | DX | SI | DI | BP
+ | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15 (**r only in 64-bit mode *)
+ (** Allocatable float regs *)
+ | X0 | X1 | X2 | X3 | X4 | X5 | X6 | X7
+ | X8 | X9 | X10 | X11 | X12 | X13 | X14 | X15 (**r only in 64-bit mode *)
+ (** Special float reg *)
+ | FP0.
+
+Lemma mreg_eq: forall (r1 r2: mreg), {r1 = r2} + {r1 <> r2}.
+Proof. decide equality. Defined.
+Global Opaque mreg_eq.
+
+Definition all_mregs :=
+ AX :: BX :: CX :: DX :: SI :: DI :: BP
+ :: R8 :: R9 :: R10 :: R11 :: R12 :: R13 :: R14 :: R15
+ :: X0 :: X1 :: X2 :: X3 :: X4 :: X5 :: X6 :: X7
+ :: X8 :: X9 :: X10 :: X11 :: X12 :: X13 :: X14 :: X15
+ :: FP0 :: nil.
+
+Lemma all_mregs_complete:
+ forall (r: mreg), In r all_mregs.
+Proof.
+ assert (forall r, proj_sumbool (In_dec mreg_eq r all_mregs) = true) by (destruct r; reflexivity).
+ intros. specialize (H r). InvBooleans. auto.
+Qed.
+
+Instance Decidable_eq_mreg : forall (x y: mreg), Decidable (eq x y) := Decidable_eq mreg_eq.
+
+Instance Finite_mreg : Finite mreg := {
+ Finite_elements := all_mregs;
+ Finite_elements_spec := all_mregs_complete
+}.
+
+Definition mreg_type (r: mreg): typ :=
+ match r with
+ | AX | BX | CX | DX | SI | DI | BP => if Archi.ptr64 then Tany64 else Tany32
+ | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15 => Tany64
+ | X0 | X1 | X2 | X3 | X4 | X5 | X6 | X7 => Tany64
+ | X8 | X9 | X10 | X11 | X12 | X13 | X14 | X15 => Tany64
+ | FP0 => Tany64
+ end.
+
+Local Open Scope positive_scope.
+
+Module IndexedMreg <: INDEXED_TYPE.
+ Definition t := mreg.
+ Definition eq := mreg_eq.
+ Definition index (r: mreg): positive :=
+ match r with
+ | AX => 1 | BX => 2 | CX => 3 | DX => 4 | SI => 5 | DI => 6 | BP => 7
+ | R8 => 8 | R9 => 9 | R10 => 10 | R11 => 11 | R12 => 12 | R13 => 13 | R14 => 14 | R15 => 15
+ | X0 => 16 | X1 => 17 | X2 => 18 | X3 => 19 | X4 => 20 | X5 => 21 | X6 => 22 | X7 => 23
+ | X8 => 24 | X9 => 25 | X10 => 26 | X11 => 27 | X12 => 28 | X13 => 29 | X14 => 30 | X15 => 31
+ | FP0 => 32
+ end.
+ Lemma index_inj:
+ forall r1 r2, index r1 = index r2 -> r1 = r2.
+ Proof.
+ decide_goal.
+ Qed.
+End IndexedMreg.
+
+Definition is_stack_reg (r: mreg) : bool :=
+ match r with FP0 => true | _ => false end.
+
+(** ** Names of registers *)
+
+Local Open Scope string_scope.
+
+Definition register_names :=
+ ("RAX", AX) :: ("RBX", BX) :: ("RCX", CX) :: ("RDX", DX) ::
+ ("RSI", SI) :: ("RDI", DI) :: ("RBP", BP) ::
+ ("EAX", AX) :: ("EBX", BX) :: ("ECX", CX) :: ("EDX", DX) ::
+ ("ESI", SI) :: ("EDI", DI) :: ("EBP", BP) ::
+ ("R8", R8) :: ("R9", R9) :: ("R10", R10) :: ("R11", R11) ::
+ ("R12", R12) :: ("R13", R13) :: ("R14", R14) :: ("R15", R15) ::
+ ("XMM0", X0) :: ("XMM1", X1) :: ("XMM2", X2) :: ("XMM3", X3) ::
+ ("XMM4", X4) :: ("XMM5", X5) :: ("XMM6", X6) :: ("XMM7", X7) ::
+ ("XMM8", X8) :: ("XMM9", X9) :: ("XMM10", X10) :: ("XMM11", X11) ::
+ ("XMM12", X12) :: ("XMM13", X13) :: ("XMM14", X14) :: ("XMM15", X15) ::
+ ("ST0", FP0) :: nil.
+
+Definition register_by_name (s: string) : option mreg :=
+ let fix assoc (l: list (string * mreg)) : option mreg :=
+ match l with
+ | nil => None
+ | (s1, r1) :: l' => if string_dec s s1 then Some r1 else assoc l'
+ end
+ in assoc register_names.
+
+(** ** Destroyed registers, preferred registers *)
+
+Definition destroyed_by_op (op: operation): list mreg :=
+ match op with
+ | Ocast8signed | Ocast8unsigned => AX :: nil
+ | Omulhs => AX :: DX :: nil
+ | Omulhu => AX :: DX :: nil
+ | Odiv => AX :: DX :: nil
+ | Odivu => AX :: DX :: nil
+ | Omod => AX :: DX :: nil
+ | Omodu => AX :: DX :: nil
+ | Oshrximm _ => CX :: nil
+ | Omullhs => AX :: DX :: nil
+ | Omullhu => AX :: DX :: nil
+ | Odivl => AX :: DX :: nil
+ | Odivlu => AX :: DX :: nil
+ | Omodl => AX :: DX :: nil
+ | Omodlu => AX :: DX :: nil
+ | Oshrxlimm _ => DX :: nil
+ | Ocmp _ => AX :: CX :: nil
+ | _ => nil
+ end.
+
+Definition destroyed_by_load (chunk: memory_chunk) (addr: addressing): list mreg :=
+ nil.
+
+Definition destroyed_by_store (chunk: memory_chunk) (addr: addressing): list mreg :=
+ match chunk with
+ | Mint8signed | Mint8unsigned => if Archi.ptr64 then nil else AX :: CX :: nil
+ | _ => nil
+ end.
+
+Definition destroyed_by_cond (cond: condition): list mreg :=
+ nil.
+
+Definition destroyed_by_jumptable: list mreg :=
+ AX :: DX :: nil.
+
+Fixpoint destroyed_by_clobber (cl: list string): list mreg :=
+ match cl with
+ | nil => nil
+ | c1 :: cl =>
+ match register_by_name c1 with
+ | Some r => r :: destroyed_by_clobber cl
+ | None => destroyed_by_clobber cl
+ end
+ end.
+
+Definition destroyed_by_builtin (ef: external_function): list mreg :=
+ match ef with
+ | EF_memcpy sz al =>
+ if zle sz 32 then CX :: X7 :: nil else CX :: SI :: DI :: nil
+ | EF_vstore (Mint8unsigned|Mint8signed) =>
+ if Archi.ptr64 then nil else AX :: CX :: nil
+ | EF_builtin name sg =>
+ if string_dec name "__builtin_va_start" then AX :: nil
+ else if string_dec name "__builtin_write16_reversed"
+ || string_dec name "__builtin_write32_reversed"
+ then CX :: DX :: nil
+ else nil
+ | EF_inline_asm txt sg clob => destroyed_by_clobber clob
+ | _ => nil
+ end.
+
+Definition destroyed_at_function_entry: list mreg :=
+ (* must include [destroyed_by_setstack ty] *)
+ AX :: FP0 :: nil.
+
+Definition destroyed_by_setstack (ty: typ): list mreg :=
+ match ty with
+ | Tfloat | Tsingle => FP0 :: nil
+ | _ => nil
+ end.
+
+Definition destroyed_at_indirect_call: list mreg :=
+ nil.
+
+Definition temp_for_parent_frame: mreg :=
+ AX.
+
+Definition mregs_for_operation (op: operation): list (option mreg) * option mreg :=
+ match op with
+ | Omulhs => (Some AX :: None :: nil, Some DX)
+ | Omulhu => (Some AX :: None :: nil, Some DX)
+ | Odiv => (Some AX :: Some CX :: nil, Some AX)
+ | Odivu => (Some AX :: Some CX :: nil, Some AX)
+ | Omod => (Some AX :: Some CX :: nil, Some DX)
+ | Omodu => (Some AX :: Some CX :: nil, Some DX)
+ | Oshl => (None :: Some CX :: nil, None)
+ | Oshr => (None :: Some CX :: nil, None)
+ | Oshru => (None :: Some CX :: nil, None)
+ | Oshrximm _ => (Some AX :: nil, Some AX)
+ | Omullhs => (Some AX :: None :: nil, Some DX)
+ | Omullhu => (Some AX :: None :: nil, Some DX)
+ | Odivl => (Some AX :: Some CX :: nil, Some AX)
+ | Odivlu => (Some AX :: Some CX :: nil, Some AX)
+ | Omodl => (Some AX :: Some CX :: nil, Some DX)
+ | Omodlu => (Some AX :: Some CX :: nil, Some DX)
+ | Oshll => (None :: Some CX :: nil, None)
+ | Oshrl => (None :: Some CX :: nil, None)
+ | Oshrlu => (None :: Some CX :: nil, None)
+ | Oshrxlimm _ => (Some AX :: nil, Some AX)
+ | _ => (nil, None)
+ end.
+
+Definition mregs_for_builtin (ef: external_function): list (option mreg) * list (option mreg) :=
+ match ef with
+ | EF_memcpy sz al =>
+ if zle sz 32 then (Some AX :: Some DX :: nil, nil) else (Some DI :: Some SI :: nil, nil)
+ | EF_builtin name sg =>
+ if string_dec name "__builtin_negl" then
+ (Some DX :: Some AX :: nil, Some DX :: Some AX :: nil)
+ else if string_dec name "__builtin_addl"
+ || string_dec name "__builtin_subl" then
+ (Some DX :: Some AX :: Some CX :: Some BX :: nil, Some DX :: Some AX :: nil)
+ else if string_dec name "__builtin_mull" then
+ (Some AX :: Some DX :: nil, Some DX :: Some AX :: nil)
+ else if string_dec name "__builtin_va_start" then
+ (Some DX :: nil, nil)
+ else if (negb Archi.ptr64) && string_dec name "__builtin_bswap64" then
+ (Some AX :: Some DX :: nil, Some DX :: Some AX :: nil)
+ else
+ (nil, nil)
+ | _ => (nil, nil)
+ end.
+
+Global Opaque
+ destroyed_by_op destroyed_by_load destroyed_by_store
+ destroyed_by_cond destroyed_by_jumptable destroyed_by_builtin
+ destroyed_by_setstack destroyed_at_function_entry temp_for_parent_frame
+ mregs_for_operation mregs_for_builtin.
+
+(** Two-address operations. Return [true] if the first argument and
+ the result must be in the same location *and* are unconstrained
+ by [mregs_for_operation]. *)
+
+Definition two_address_op (op: operation) : bool :=
+ match op with
+ | Omove => false
+ | Ointconst _ => false
+ | Olongconst _ => false
+ | Ofloatconst _ => false
+ | Osingleconst _ => false
+ | Oindirectsymbol _ => false
+ | Ocast8signed => false
+ | Ocast8unsigned => false
+ | Ocast16signed => false
+ | Ocast16unsigned => false
+ | Oneg => true
+ | Osub => true
+ | Omul => true
+ | Omulimm _ => true
+ | Omulhs => false
+ | Omulhu => false
+ | Odiv => false
+ | Odivu => false
+ | Omod => false
+ | Omodu => false
+ | Oand => true
+ | Oandimm _ => true
+ | Oor => true
+ | Oorimm _ => true
+ | Oxor => true
+ | Oxorimm _ => true
+ | Onot => true
+ | Oshl => true
+ | Oshlimm _ => true
+ | Oshr => true
+ | Oshrimm _ => true
+ | Oshrximm _ => false
+ | Oshru => true
+ | Oshruimm _ => true
+ | Ororimm _ => true
+ | Oshldimm _ => true
+ | Olea addr => false
+ | Omakelong => true
+ | Olowlong => true
+ | Ohighlong => true
+ | Ocast32signed => false
+ | Ocast32unsigned => false
+ | Onegl => true
+ | Oaddlimm _ => true
+ | Osubl => true
+ | Omull => true
+ | Omullimm _ => true
+ | Omullhs => false
+ | Omullhu => false
+ | Odivl => false
+ | Odivlu => false
+ | Omodl => false
+ | Omodlu => false
+ | Oandl => true
+ | Oandlimm _ => true
+ | Oorl => true
+ | Oorlimm _ => true
+ | Oxorl => true
+ | Oxorlimm _ => true
+ | Onotl => true
+ | Oshll => true
+ | Oshllimm _ => true
+ | Oshrl => true
+ | Oshrlimm _ => true
+ | Oshrxlimm _ => false
+ | Oshrlu => true
+ | Oshrluimm _ => true
+ | Ororlimm _ => true
+ | Oleal addr => false
+ | Onegf => true
+ | Oabsf => true
+ | Oaddf => true
+ | Osubf => true
+ | Omulf => true
+ | Odivf => true
+ | Onegfs => true
+ | Oabsfs => true
+ | Oaddfs => true
+ | Osubfs => true
+ | Omulfs => true
+ | Odivfs => true
+ | Osingleoffloat => false
+ | Ofloatofsingle => false
+ | Ointoffloat => false
+ | Ofloatofint => false
+ | Ointofsingle => false
+ | Osingleofint => false
+ | Olongoffloat => false
+ | Ofloatoflong => false
+ | Olongofsingle => false
+ | Osingleoflong => false
+ | Ocmp c => false
+ end.
+
+(* Constraints on constant propagation for builtins *)
+
+Definition builtin_constraints (ef: external_function) :
+ list builtin_arg_constraint :=
+ match ef with
+ | EF_vload _ => OK_addrany :: nil
+ | EF_vstore _ => OK_addrany :: OK_default :: nil
+ | EF_memcpy _ _ => OK_addrany :: OK_addrany :: nil
+ | EF_annot txt targs => map (fun _ => OK_all) targs
+ | EF_debug kind txt targs => map (fun _ => OK_all) targs
+ | _ => nil
+ end.
diff --git a/x86/Machregsaux.ml b/x86/Machregsaux.ml
new file mode 100644
index 00000000..473e0602
--- /dev/null
+++ b/x86/Machregsaux.ml
@@ -0,0 +1,33 @@
+(* *********************************************************************)
+(* *)
+(* 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. *)
+(* *)
+(* *********************************************************************)
+
+(** Auxiliary functions on machine registers *)
+
+open Camlcoq
+open Machregs
+
+let register_names : (mreg, string) Hashtbl.t = Hashtbl.create 31
+
+let _ =
+ List.iter
+ (fun (s, r) -> Hashtbl.add register_names r (camlstring_of_coqstring s))
+ Machregs.register_names
+
+let is_scratch_register r = false
+
+let name_of_register r =
+ try Some (Hashtbl.find register_names r) with Not_found -> None
+
+let register_by_name s =
+ Machregs.register_by_name (coqstring_uppercase_ascii_of_camlstring s)
+
+let can_reserve_register r = Conventions1.is_callee_save r
diff --git a/x86/Machregsaux.mli b/x86/Machregsaux.mli
new file mode 100644
index 00000000..9404568d
--- /dev/null
+++ b/x86/Machregsaux.mli
@@ -0,0 +1,18 @@
+(* *********************************************************************)
+(* *)
+(* 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. *)
+(* *)
+(* *********************************************************************)
+
+(** Auxiliary functions on machine registers *)
+
+val name_of_register: Machregs.mreg -> string option
+val register_by_name: string -> Machregs.mreg option
+val is_scratch_register: string -> bool
+val can_reserve_register: Machregs.mreg -> bool
diff --git a/x86/NeedOp.v b/x86/NeedOp.v
new file mode 100644
index 00000000..09013cdd
--- /dev/null
+++ b/x86/NeedOp.v
@@ -0,0 +1,254 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris *)
+(* *)
+(* 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. *)
+(* *)
+(* *********************************************************************)
+
+(** Neededness analysis for x86_64 operators *)
+
+Require Import Coqlib.
+Require Import AST Integers Floats Values Memory Globalenvs.
+Require Import Op NeedDomain RTL.
+
+Definition op1 (nv: nval) := nv :: nil.
+Definition op2 (nv: nval) := nv :: nv :: nil.
+
+Definition needs_of_condition (cond: condition): list nval :=
+ match cond with
+ | Cmaskzero n | Cmasknotzero n => op1 (maskzero n)
+ | _ => nil
+ end.
+
+Definition needs_of_addressing_32 (addr: addressing) (nv: nval): list nval :=
+ match addr with
+ | Aindexed n => op1 (modarith nv)
+ | Aindexed2 n => op2 (modarith nv)
+ | Ascaled sc ofs => op1 (modarith (modarith nv))
+ | Aindexed2scaled sc ofs => op2 (modarith nv)
+ | Aglobal s ofs => nil
+ | Abased s ofs => op1 (modarith nv)
+ | Abasedscaled sc s ofs => op1 (modarith (modarith nv))
+ | Ainstack ofs => nil
+ end.
+
+Definition needs_of_addressing_64 (addr: addressing) (nv: nval): list nval :=
+ match addr with
+ | Aindexed n => op1 (default nv)
+ | Aindexed2 n => op2 (default nv)
+ | Ascaled sc ofs => op1 (default nv)
+ | Aindexed2scaled sc ofs => op2 (default nv)
+ | Aglobal s ofs => nil
+ | Abased s ofs => op1 (default nv)
+ | Abasedscaled sc s ofs => op1 (default nv)
+ | Ainstack ofs => nil
+ end.
+
+Definition needs_of_addressing (addr: addressing) (nv: nval): list nval :=
+ if Archi.ptr64 then needs_of_addressing_64 addr nv else needs_of_addressing_32 addr nv.
+
+Definition needs_of_operation (op: operation) (nv: nval): list nval :=
+ match op with
+ | Omove => op1 nv
+ | Ointconst n => nil
+ | Olongconst n => nil
+ | Ofloatconst n => nil
+ | Osingleconst n => nil
+ | Oindirectsymbol id => nil
+ | Ocast8signed => op1 (sign_ext 8 nv)
+ | Ocast8unsigned => op1 (zero_ext 8 nv)
+ | Ocast16signed => op1 (sign_ext 16 nv)
+ | Ocast16unsigned => op1 (zero_ext 16 nv)
+ | Oneg => op1 (modarith nv)
+ | Osub => op2 (default nv)
+ | Omul => op2 (modarith nv)
+ | Omulimm n => op1 (modarith nv)
+ | Omulhs | Omulhu | Odiv | Odivu | Omod | Omodu => op2 (default nv)
+ | Oand => op2 (bitwise nv)
+ | Oandimm n => op1 (andimm nv n)
+ | Oor => op2 (bitwise nv)
+ | Oorimm n => op1 (orimm nv n)
+ | Oxor => op2 (bitwise nv)
+ | Oxorimm n => op1 (bitwise nv)
+ | Onot => op1 (bitwise nv)
+ | Oshl => op2 (default nv)
+ | Oshlimm n => op1 (shlimm nv n)
+ | Oshr => op2 (default nv)
+ | Oshrimm n => op1 (shrimm nv n)
+ | Oshrximm n => op1 (default nv)
+ | Oshru => op2 (default nv)
+ | Oshruimm n => op1 (shruimm nv n)
+ | Ororimm n => op1 (ror nv n)
+ | Oshldimm n => op1 (default nv)
+ | Olea addr => needs_of_addressing_32 addr nv
+ | Omakelong => op2 (default nv)
+ | Olowlong | Ohighlong => op1 (default nv)
+ | Ocast32signed => op1 (default nv)
+ | Ocast32unsigned => op1 (default nv)
+ | Onegl => op1 (default nv)
+ | Oaddlimm _ => op1 (default nv)
+ | Osubl => op2 (default nv)
+ | Omull => op2 (default nv)
+ | Omullimm _ => op1 (default nv)
+ | Omullhs | Omullhu | Odivl | Odivlu | Omodl | Omodlu => op2 (default nv)
+ | Oandl => op2 (default nv)
+ | Oandlimm _ => op1 (default nv)
+ | Oorl => op2 (default nv)
+ | Oorlimm _ => op1 (default nv)
+ | Oxorl => op2 (default nv)
+ | Oxorlimm _ => op1 (default nv)
+ | Onotl => op1 (default nv)
+ | Oshll => op2 (default nv)
+ | Oshllimm _ => op1 (default nv)
+ | Oshrl => op2 (default nv)
+ | Oshrlimm _ => op1 (default nv)
+ | Oshrxlimm n => op1 (default nv)
+ | Oshrlu => op2 (default nv)
+ | Oshrluimm _ => op1 (default nv)
+ | Ororlimm _ => op1 (default nv)
+ | Oleal addr => needs_of_addressing_64 addr nv
+ | Onegf | Oabsf => op1 (default nv)
+ | Oaddf | Osubf | Omulf | Odivf => op2 (default nv)
+ | Onegfs | Oabsfs => op1 (default nv)
+ | Oaddfs | Osubfs | Omulfs | Odivfs => op2 (default nv)
+ | Osingleoffloat | Ofloatofsingle => op1 (default nv)
+ | Ointoffloat | Ofloatofint | Ointofsingle | Osingleofint => op1 (default nv)
+ | Olongoffloat | Ofloatoflong | Olongofsingle | Osingleoflong => op1 (default nv)
+ | Ocmp c => needs_of_condition c
+ end.
+
+Definition operation_is_redundant (op: operation) (nv: nval): bool :=
+ match op with
+ | Ocast8signed => sign_ext_redundant 8 nv
+ | Ocast8unsigned => zero_ext_redundant 8 nv
+ | Ocast16signed => sign_ext_redundant 16 nv
+ | Ocast16unsigned => zero_ext_redundant 16 nv
+ | Oandimm n => andimm_redundant nv n
+ | Oorimm n => orimm_redundant nv n
+ | _ => false
+ end.
+
+Ltac InvAgree :=
+ match goal with
+ | [H: vagree_list nil _ _ |- _ ] => inv H; InvAgree
+ | [H: vagree_list (_::_) _ _ |- _ ] => inv H; InvAgree
+ | _ => idtac
+ end.
+
+Ltac TrivialExists :=
+ match goal with
+ | [ |- exists v, Some ?x = Some v /\ _ ] => exists x; split; auto
+ | _ => idtac
+ end.
+
+Section SOUNDNESS.
+
+Variable ge: genv.
+Variable sp: block.
+Variables m m': mem.
+Hypothesis PERM: forall b ofs k p, Mem.perm m b ofs k p -> Mem.perm m' b ofs k p.
+
+Lemma needs_of_condition_sound:
+ forall cond args b args',
+ eval_condition cond args m = Some b ->
+ vagree_list args args' (needs_of_condition cond) ->
+ eval_condition cond args' m' = Some b.
+Proof.
+ intros. destruct cond; simpl in H;
+ try (eapply default_needs_of_condition_sound; eauto; fail);
+ simpl in *; FuncInv; InvAgree.
+- eapply maskzero_sound; eauto.
+- destruct (Val.maskzero_bool v n) as [b'|] eqn:MZ; try discriminate.
+ erewrite maskzero_sound; eauto.
+Qed.
+
+Lemma needs_of_addressing_32_sound:
+ forall sp addr args v nv args',
+ eval_addressing32 ge (Vptr sp Ptrofs.zero) addr args = Some v ->
+ vagree_list args args' (needs_of_addressing_32 addr nv) ->
+ exists v',
+ eval_addressing32 ge (Vptr sp Ptrofs.zero) addr args' = Some v'
+ /\ vagree v v' nv.
+Proof.
+ unfold needs_of_addressing_32; intros.
+ destruct addr; simpl in *; FuncInv; InvAgree; TrivialExists;
+ auto using add_sound, mul_sound with na.
+ apply add_sound; auto with na. apply add_sound; rewrite modarith_idem; auto.
+ apply add_sound; auto. apply add_sound; rewrite modarith_idem; auto with na.
+ apply mul_sound; rewrite modarith_idem; auto with na.
+Qed.
+
+(*
+Lemma needs_of_addressing_64_sound:
+ forall sp addr args v nv args',
+ eval_addressing64 ge (Vptr sp Ptrofs.zero) addr args = Some v ->
+ vagree_list args args' (needs_of_addressing_64 addr nv) ->
+ exists v',
+ eval_addressing64 ge (Vptr sp Ptrofs.zero) addr args' = Some v'
+ /\ vagree v v' nv.
+*)
+
+Lemma needs_of_operation_sound:
+ forall op args v nv args',
+ eval_operation ge (Vptr sp Ptrofs.zero) op args m = Some v ->
+ vagree_list args args' (needs_of_operation op nv) ->
+ nv <> Nothing ->
+ exists v',
+ eval_operation ge (Vptr sp Ptrofs.zero) op args' m' = Some v'
+ /\ vagree v v' nv.
+Proof.
+ unfold needs_of_operation; intros; destruct op; try (eapply default_needs_of_operation_sound; eauto; fail);
+ simpl in *; FuncInv; InvAgree; TrivialExists.
+- apply sign_ext_sound; auto. compute; auto.
+- apply zero_ext_sound; auto. omega.
+- apply sign_ext_sound; auto. compute; auto.
+- apply zero_ext_sound; auto. omega.
+- apply neg_sound; auto.
+- apply mul_sound; auto.
+- apply mul_sound; auto with na.
+- apply and_sound; auto.
+- apply andimm_sound; auto.
+- apply or_sound; auto.
+- apply orimm_sound; auto.
+- apply xor_sound; auto.
+- apply xor_sound; auto with na.
+- apply notint_sound; auto.
+- apply shlimm_sound; auto.
+- apply shrimm_sound; auto.
+- apply shruimm_sound; auto.
+- apply ror_sound; auto.
+- eapply needs_of_addressing_32_sound; eauto.
+- change (eval_addressing64 ge (Vptr sp Ptrofs.zero) a args')
+ with (eval_operation ge (Vptr sp Ptrofs.zero) (Oleal a) args' m').
+ eapply default_needs_of_operation_sound; eauto.
+ destruct a; simpl in H0; auto.
+- destruct (eval_condition cond args m) as [b|] eqn:EC; simpl in H2.
+ erewrite needs_of_condition_sound by eauto.
+ subst v; simpl. auto with na.
+ subst v; auto with na.
+Qed.
+
+Lemma operation_is_redundant_sound:
+ forall op nv arg1 args v arg1' args',
+ operation_is_redundant op nv = true ->
+ eval_operation ge (Vptr sp Ptrofs.zero) op (arg1 :: args) m = Some v ->
+ vagree_list (arg1 :: args) (arg1' :: args') (needs_of_operation op nv) ->
+ vagree v arg1' nv.
+Proof.
+ intros. destruct op; simpl in *; try discriminate; inv H1; FuncInv; subst.
+- apply sign_ext_redundant_sound; auto. omega.
+- apply zero_ext_redundant_sound; auto. omega.
+- apply sign_ext_redundant_sound; auto. omega.
+- apply zero_ext_redundant_sound; auto. omega.
+- apply andimm_redundant_sound; auto.
+- apply orimm_redundant_sound; auto.
+Qed.
+
+End SOUNDNESS.
+
+
diff --git a/x86/Op.v b/x86/Op.v
new file mode 100644
index 00000000..0de3e061
--- /dev/null
+++ b/x86/Op.v
@@ -0,0 +1,1452 @@
+(* *********************************************************************)
+(* *)
+(* 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 X86-64-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 Memory.
+Require Import Globalenvs.
+Require Import Events.
+
+Set Implicit Arguments.
+
+(** Conditions (boolean-valued operators). *)
+
+Inductive condition : Type :=
+ | Ccomp (c: comparison) (**r signed integer comparison *)
+ | Ccompu (c: comparison) (**r unsigned integer comparison *)
+ | Ccompimm (c: comparison) (n: int) (**r signed integer comparison with a constant *)
+ | Ccompuimm (c: comparison) (n: int) (**r unsigned integer comparison with a constant *)
+ | Ccompl (c: comparison) (**r signed 64-bit integer comparison *)
+ | Ccomplu (c: comparison) (**r unsigned 64-bit integer comparison *)
+ | Ccomplimm (c: comparison) (n: int64) (**r signed 64-bit integer comparison with a constant *)
+ | Ccompluimm (c: comparison) (n: int64) (**r unsigned 64-bit integer comparison with a constant *)
+ | Ccompf (c: comparison) (**r 64-bit floating-point comparison *)
+ | Cnotcompf (c: comparison) (**r negation of a floating-point comparison *)
+ | Ccompfs (c: comparison) (**r 32-bit floating-point comparison *)
+ | Cnotcompfs (c: comparison) (**r negation of a floating-point comparison *)
+ | Cmaskzero (n: int) (**r test [(arg & constant) == 0] *)
+ | Cmasknotzero (n: int). (**r test [(arg & constant) != 0] *)
+
+(** Addressing modes. [r1], [r2], etc, are the arguments to the
+ addressing. *)
+
+Inductive addressing: Type :=
+ | Aindexed: Z -> addressing (**r Address is [r1 + offset] *)
+ | Aindexed2: Z -> addressing (**r Address is [r1 + r2 + offset] *)
+ | Ascaled: Z -> Z -> addressing (**r Address is [r1 * scale + offset] *)
+ | Aindexed2scaled: Z -> Z -> addressing
+ (**r Address is [r1 + r2 * scale + offset] *)
+ | Aglobal: ident -> ptrofs -> addressing (**r Address is [symbol + offset] *)
+ | Abased: ident -> ptrofs -> addressing (**r Address is [symbol + offset + r1] *)
+ | Abasedscaled: Z -> ident -> ptrofs -> addressing (**r Address is [symbol + offset + r1 * scale] *)
+ | Ainstack: ptrofs -> addressing. (**r Address is [stack_pointer + offset] *)
+
+(** Arithmetic and logical operations. In the descriptions, [rd] is the
+ result of the operation and [r1], [r2], etc, are the arguments. *)
+
+Inductive operation : Type :=
+ | Omove (**r [rd = r1] *)
+ | Ointconst (n: int) (**r [rd] is set to the given integer constant *)
+ | Olongconst (n: int64) (**r [rd] is set to the given integer constant *)
+ | Ofloatconst (n: float) (**r [rd] is set to the given float constant *)
+ | Osingleconst (n: float32)(**r [rd] is set to the given float constant *)
+ | Oindirectsymbol (id: ident) (**r [rd] is set to the address of the symbol *)
+(*c 32-bit integer arithmetic: *)
+ | Ocast8signed (**r [rd] is 8-bit sign extension of [r1] *)
+ | Ocast8unsigned (**r [rd] is 8-bit zero extension of [r1] *)
+ | Ocast16signed (**r [rd] is 16-bit sign extension of [r1] *)
+ | Ocast16unsigned (**r [rd] is 16-bit zero extension of [r1] *)
+ | Oneg (**r [rd = - r1] *)
+ | Osub (**r [rd = r1 - r2] *)
+ | Omul (**r [rd = r1 * r2] *)
+ | Omulimm (n: int) (**r [rd = r1 * n] *)
+ | Omulhs (**r [rd = high part of r1 * r2, signed] *)
+ | Omulhu (**r [rd = high part of r1 * r2, unsigned] *)
+ | Odiv (**r [rd = r1 / r2] (signed) *)
+ | Odivu (**r [rd = r1 / r2] (unsigned) *)
+ | Omod (**r [rd = r1 % r2] (signed) *)
+ | Omodu (**r [rd = r1 % r2] (unsigned) *)
+ | Oand (**r [rd = r1 & r2] *)
+ | Oandimm (n: int) (**r [rd = r1 & n] *)
+ | Oor (**r [rd = r1 | r2] *)
+ | Oorimm (n: int) (**r [rd = r1 | n] *)
+ | Oxor (**r [rd = r1 ^ r2] *)
+ | Oxorimm (n: int) (**r [rd = r1 ^ n] *)
+ | Onot (**r [rd = ~r1] *)
+ | Oshl (**r [rd = r1 << r2] *)
+ | Oshlimm (n: int) (**r [rd = r1 << n] *)
+ | Oshr (**r [rd = r1 >> r2] (signed) *)
+ | Oshrimm (n: int) (**r [rd = r1 >> n] (signed) *)
+ | Oshrximm (n: int) (**r [rd = r1 / 2^n] (signed) *)
+ | Oshru (**r [rd = r1 >> r2] (unsigned) *)
+ | Oshruimm (n: int) (**r [rd = r1 >> n] (unsigned) *)
+ | Ororimm (n: int) (**r rotate right immediate *)
+ | Oshldimm (n: int) (**r [rd = r1 << n | r2 >> (32-n)] *)
+ | Olea (a: addressing) (**r effective address *)
+(*c 64-bit integer arithmetic: *)
+ | Omakelong (**r [rd = r1 << 32 | r2] *)
+ | Olowlong (**r [rd = low-word(r1)] *)
+ | Ohighlong (**r [rd = high-word(r1)] *)
+ | Ocast32signed (**r [rd] is 32-bit sign extension of [r1] *)
+ | Ocast32unsigned (**r [rd] is 32-bit zero extension of [r1] *)
+ | Onegl (**r [rd = - r1] *)
+ | Oaddlimm (n: int64) (**r [rd = r1 + n] *)
+ | Osubl (**r [rd = r1 - r2] *)
+ | Omull (**r [rd = r1 * r2] *)
+ | Omullimm (n: int64) (**r [rd = r1 * n] *)
+ | Omullhs (**r [rd = high part of r1 * r2, signed] *)
+ | Omullhu (**r [rd = high part of r1 * r2, unsigned] *)
+ | Odivl (**r [rd = r1 / r2] (signed) *)
+ | Odivlu (**r [rd = r1 / r2] (unsigned) *)
+ | Omodl (**r [rd = r1 % r2] (signed) *)
+ | Omodlu (**r [rd = r1 % r2] (unsigned) *)
+ | Oandl (**r [rd = r1 & r2] *)
+ | Oandlimm (n: int64) (**r [rd = r1 & n] *)
+ | Oorl (**r [rd = r1 | r2] *)
+ | Oorlimm (n: int64) (**r [rd = r1 | n] *)
+ | Oxorl (**r [rd = r1 ^ r2] *)
+ | Oxorlimm (n: int64) (**r [rd = r1 ^ n] *)
+ | Onotl (**r [rd = ~r1] *)
+ | Oshll (**r [rd = r1 << r2] *)
+ | Oshllimm (n: int) (**r [rd = r1 << n] *)
+ | Oshrl (**r [rd = r1 >> r2] (signed) *)
+ | Oshrlimm (n: int) (**r [rd = r1 >> n] (signed) *)
+ | Oshrxlimm (n: int) (**r [rd = r1 / 2^n] (signed) *)
+ | Oshrlu (**r [rd = r1 >> r2] (unsigned) *)
+ | Oshrluimm (n: int) (**r [rd = r1 >> n] (unsigned) *)
+ | Ororlimm (n: int) (**r rotate right immediate *)
+ | Oleal (a: addressing) (**r effective address *)
+(*c Floating-point arithmetic: *)
+ | Onegf (**r [rd = - r1] *)
+ | Oabsf (**r [rd = abs(r1)] *)
+ | Oaddf (**r [rd = r1 + r2] *)
+ | Osubf (**r [rd = r1 - r2] *)
+ | Omulf (**r [rd = r1 * r2] *)
+ | Odivf (**r [rd = r1 / r2] *)
+ | Onegfs (**r [rd = - r1] *)
+ | Oabsfs (**r [rd = abs(r1)] *)
+ | Oaddfs (**r [rd = r1 + r2] *)
+ | Osubfs (**r [rd = r1 - r2] *)
+ | Omulfs (**r [rd = r1 * r2] *)
+ | Odivfs (**r [rd = r1 / r2] *)
+ | Osingleoffloat (**r [rd] is [r1] truncated to single-precision float *)
+ | Ofloatofsingle (**r [rd] is [r1] extended to double-precision float *)
+(*c Conversions between int and float: *)
+ | Ointoffloat (**r [rd = signed_int_of_float64(r1)] *)
+ | Ofloatofint (**r [rd = float64_of_signed_int(r1)] *)
+ | Ointofsingle (**r [rd = signed_int_of_float32(r1)] *)
+ | Osingleofint (**r [rd = float32_of_signed_int(r1)] *)
+ | Olongoffloat (**r [rd = signed_long_of_float64(r1)] *)
+ | Ofloatoflong (**r [rd = float64_of_signed_long(r1)] *)
+ | Olongofsingle (**r [rd = signed_long_of_float32(r1)] *)
+ | Osingleoflong (**r [rd = float32_of_signed_long(r1)] *)
+(*c Boolean tests: *)
+ | Ocmp (cond: condition). (**r [rd = 1] if condition holds, [rd = 0] otherwise. *)
+
+(** Comparison functions (used in modules [CSE] and [Allocation]). *)
+
+Definition eq_condition (x y: condition) : {x=y} + {x<>y}.
+Proof.
+ generalize Int.eq_dec Int64.eq_dec; intro.
+ assert (forall (x y: comparison), {x=y}+{x<>y}). decide equality.
+ decide equality.
+Defined.
+
+Definition eq_addressing (x y: addressing) : {x=y} + {x<>y}.
+Proof.
+ generalize ident_eq Ptrofs.eq_dec zeq; intros.
+ decide equality.
+Defined.
+
+Definition eq_operation (x y: operation): {x=y} + {x<>y}.
+Proof.
+ generalize Int.eq_dec Int64.eq_dec Float.eq_dec Float32.eq_dec; intros.
+ decide equality.
+ apply ident_eq.
+ apply eq_addressing.
+ apply eq_addressing.
+ apply eq_condition.
+Defined.
+
+Global Opaque eq_condition eq_addressing eq_operation.
+
+(** In addressing modes, offsets are 32-bit signed integers, even in 64-bit mode.
+ The following function checks that an addressing mode is valid, i.e. that
+ the offsets are in range. *)
+
+Definition offset_in_range (n: Z) : bool := zle Int.min_signed n && zle n Int.max_signed.
+
+Definition addressing_valid (a: addressing) : bool :=
+ match a with
+ | Aindexed n => offset_in_range n
+ | Aindexed2 n => offset_in_range n
+ | Ascaled sc ofs => offset_in_range ofs
+ | Aindexed2scaled sc ofs => offset_in_range ofs
+ | Aglobal s ofs => true
+ | Abased s ofs => true
+ | Abasedscaled sc s ofs => true
+ | Ainstack ofs => offset_in_range (Ptrofs.signed ofs)
+ end.
+
+(** * Evaluation functions *)
+
+(** Evaluation of conditions, operators and addressing modes applied
+ to lists of values. Return [None] when the computation can trigger an
+ error, e.g. integer division by zero. [eval_condition] returns a boolean,
+ [eval_operation] and [eval_addressing] return a value. *)
+
+Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool :=
+ match cond, vl with
+ | Ccomp c, v1 :: v2 :: nil => Val.cmp_bool c v1 v2
+ | Ccompu c, v1 :: v2 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 v2
+ | Ccompimm c n, v1 :: nil => Val.cmp_bool c v1 (Vint n)
+ | Ccompuimm c n, v1 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 (Vint n)
+ | Ccompl c, v1 :: v2 :: nil => Val.cmpl_bool c v1 v2
+ | Ccomplu c, v1 :: v2 :: nil => Val.cmplu_bool (Mem.valid_pointer m) c v1 v2
+ | Ccomplimm c n, v1 :: nil => Val.cmpl_bool c v1 (Vlong n)
+ | Ccompluimm c n, v1 :: nil => Val.cmplu_bool (Mem.valid_pointer m) c v1 (Vlong n)
+ | Ccompf c, v1 :: v2 :: nil => Val.cmpf_bool c v1 v2
+ | Cnotcompf c, v1 :: v2 :: nil => option_map negb (Val.cmpf_bool c v1 v2)
+ | Ccompfs c, v1 :: v2 :: nil => Val.cmpfs_bool c v1 v2
+ | Cnotcompfs c, v1 :: v2 :: nil => option_map negb (Val.cmpfs_bool c v1 v2)
+ | Cmaskzero n, v1 :: nil => Val.maskzero_bool v1 n
+ | Cmasknotzero n, v1 :: nil => option_map negb (Val.maskzero_bool v1 n)
+ | _, _ => None
+ end.
+
+Definition eval_addressing32
+ (F V: Type) (genv: Genv.t F V) (sp: val)
+ (addr: addressing) (vl: list val) : option val :=
+ match addr, vl with
+ | Aindexed n, v1::nil =>
+ Some (Val.add v1 (Vint (Int.repr n)))
+ | Aindexed2 n, v1::v2::nil =>
+ Some (Val.add (Val.add v1 v2) (Vint (Int.repr n)))
+ | Ascaled sc ofs, v1::nil =>
+ Some (Val.add (Val.mul v1 (Vint (Int.repr sc))) (Vint (Int.repr ofs)))
+ | Aindexed2scaled sc ofs, v1::v2::nil =>
+ Some(Val.add v1 (Val.add (Val.mul v2 (Vint (Int.repr sc))) (Vint (Int.repr ofs))))
+ | Aglobal s ofs, nil =>
+ if Archi.ptr64 then None else Some (Genv.symbol_address genv s ofs)
+ | Abased s ofs, v1::nil =>
+ if Archi.ptr64 then None else Some (Val.add (Genv.symbol_address genv s ofs) v1)
+ | Abasedscaled sc s ofs, v1::nil =>
+ if Archi.ptr64 then None else Some (Val.add (Genv.symbol_address genv s ofs) (Val.mul v1 (Vint (Int.repr sc))))
+ | Ainstack ofs, nil =>
+ if Archi.ptr64 then None else Some(Val.offset_ptr sp ofs)
+ | _, _ => None
+ end.
+
+Definition eval_addressing64
+ (F V: Type) (genv: Genv.t F V) (sp: val)
+ (addr: addressing) (vl: list val) : option val :=
+ match addr, vl with
+ | Aindexed n, v1::nil =>
+ Some (Val.addl v1 (Vlong (Int64.repr n)))
+ | Aindexed2 n, v1::v2::nil =>
+ Some (Val.addl (Val.addl v1 v2) (Vlong (Int64.repr n)))
+ | Ascaled sc ofs, v1::nil =>
+ Some (Val.addl (Val.mull v1 (Vlong (Int64.repr sc))) (Vlong (Int64.repr ofs)))
+ | Aindexed2scaled sc ofs, v1::v2::nil =>
+ Some(Val.addl v1 (Val.addl (Val.mull v2 (Vlong (Int64.repr sc))) (Vlong (Int64.repr ofs))))
+ | Aglobal s ofs, nil =>
+ if Archi.ptr64 then Some (Genv.symbol_address genv s ofs) else None
+ | Ainstack ofs, nil =>
+ if Archi.ptr64 then Some(Val.offset_ptr sp ofs) else None
+ | _, _ => None
+ end.
+
+Definition eval_addressing
+ (F V: Type) (genv: Genv.t F V) (sp: val)
+ (addr: addressing) (vl: list val) : option val :=
+ if Archi.ptr64
+ then eval_addressing64 genv sp addr vl
+ else eval_addressing32 genv sp addr vl.
+
+Definition eval_operation
+ (F V: Type) (genv: Genv.t F V) (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)
+ | Olongconst n, nil => Some (Vlong n)
+ | Ofloatconst n, nil => Some (Vfloat n)
+ | Osingleconst n, nil => Some (Vsingle n)
+ | Oindirectsymbol id, nil => Some (Genv.symbol_address genv id Ptrofs.zero)
+ | 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)
+ | Oneg, v1::nil => Some (Val.neg v1)
+ | Osub, v1::v2::nil => Some (Val.sub v1 v2)
+ | Omul, v1::v2::nil => Some (Val.mul v1 v2)
+ | Omulimm n, v1::nil => Some (Val.mul v1 (Vint n))
+ | Omulhs, v1::v2::nil => Some (Val.mulhs v1 v2)
+ | Omulhu, v1::v2::nil => Some (Val.mulhu v1 v2)
+ | Odiv, v1::v2::nil => Val.divs v1 v2
+ | Odivu, v1::v2::nil => Val.divu v1 v2
+ | Omod, v1::v2::nil => Val.mods v1 v2
+ | Omodu, v1::v2::nil => Val.modu v1 v2
+ | Oand, v1::v2::nil => Some(Val.and v1 v2)
+ | Oandimm n, v1::nil => Some (Val.and v1 (Vint n))
+ | Oor, v1::v2::nil => Some(Val.or v1 v2)
+ | Oorimm n, v1::nil => Some (Val.or v1 (Vint n))
+ | Oxor, v1::v2::nil => Some(Val.xor v1 v2)
+ | Oxorimm n, v1::nil => Some (Val.xor v1 (Vint n))
+ | Onot, v1::nil => Some(Val.notint v1)
+ | Oshl, v1::v2::nil => Some (Val.shl v1 v2)
+ | Oshlimm n, v1::nil => Some (Val.shl v1 (Vint n))
+ | Oshr, v1::v2::nil => Some (Val.shr v1 v2)
+ | Oshrimm n, v1::nil => Some (Val.shr v1 (Vint n))
+ | Oshrximm n, v1::nil => Val.shrx v1 (Vint n)
+ | Oshru, v1::v2::nil => Some (Val.shru v1 v2)
+ | Oshruimm n, v1::nil => Some (Val.shru v1 (Vint n))
+ | Ororimm n, v1::nil => Some (Val.ror v1 (Vint n))
+ | Oshldimm n, v1::v2::nil => Some (Val.or (Val.shl v1 (Vint n))
+ (Val.shru v2 (Vint (Int.sub Int.iwordsize n))))
+ | Olea addr, _ => eval_addressing32 genv sp addr vl
+ | Omakelong, v1::v2::nil => Some(Val.longofwords v1 v2)
+ | Olowlong, v1::nil => Some(Val.loword v1)
+ | Ohighlong, v1::nil => Some(Val.hiword v1)
+ | Ocast32signed, v1 :: nil => Some (Val.longofint v1)
+ | Ocast32unsigned, v1 :: nil => Some (Val.longofintu v1)
+ | Onegl, v1::nil => Some (Val.negl v1)
+ | Oaddlimm n, v1::nil => Some (Val.addl v1 (Vlong n))
+ | Osubl, v1::v2::nil => Some (Val.subl v1 v2)
+ | Omull, v1::v2::nil => Some (Val.mull v1 v2)
+ | Omullimm n, v1::nil => Some (Val.mull v1 (Vlong n))
+ | Omullhs, v1::v2::nil => Some (Val.mullhs v1 v2)
+ | Omullhu, v1::v2::nil => Some (Val.mullhu v1 v2)
+ | Odivl, v1::v2::nil => Val.divls v1 v2
+ | Odivlu, v1::v2::nil => Val.divlu v1 v2
+ | Omodl, v1::v2::nil => Val.modls v1 v2
+ | Omodlu, v1::v2::nil => Val.modlu v1 v2
+ | Oandl, v1::v2::nil => Some(Val.andl v1 v2)
+ | Oandlimm n, v1::nil => Some (Val.andl v1 (Vlong n))
+ | Oorl, v1::v2::nil => Some(Val.orl v1 v2)
+ | Oorlimm n, v1::nil => Some (Val.orl v1 (Vlong n))
+ | Oxorl, v1::v2::nil => Some(Val.xorl v1 v2)
+ | Oxorlimm n, v1::nil => Some (Val.xorl v1 (Vlong n))
+ | Onotl, v1::nil => Some(Val.notl v1)
+ | Oshll, v1::v2::nil => Some (Val.shll v1 v2)
+ | Oshllimm n, v1::nil => Some (Val.shll v1 (Vint n))
+ | Oshrl, v1::v2::nil => Some (Val.shrl v1 v2)
+ | Oshrlimm n, v1::nil => Some (Val.shrl v1 (Vint n))
+ | Oshrxlimm n, v1::nil => Val.shrxl v1 (Vint n)
+ | Oshrlu, v1::v2::nil => Some (Val.shrlu v1 v2)
+ | Oshrluimm n, v1::nil => Some (Val.shrlu v1 (Vint n))
+ | Ororlimm n, v1::nil => Some (Val.rorl v1 (Vint n))
+ | Oleal addr, _ => eval_addressing64 genv sp addr vl
+ | Onegf, v1::nil => Some(Val.negf v1)
+ | Oabsf, v1::nil => Some(Val.absf v1)
+ | Oaddf, v1::v2::nil => Some(Val.addf v1 v2)
+ | Osubf, v1::v2::nil => Some(Val.subf v1 v2)
+ | Omulf, v1::v2::nil => Some(Val.mulf v1 v2)
+ | Odivf, v1::v2::nil => Some(Val.divf v1 v2)
+ | Onegfs, v1::nil => Some(Val.negfs v1)
+ | Oabsfs, v1::nil => Some(Val.absfs v1)
+ | Oaddfs, v1::v2::nil => Some(Val.addfs v1 v2)
+ | Osubfs, v1::v2::nil => Some(Val.subfs v1 v2)
+ | Omulfs, v1::v2::nil => Some(Val.mulfs v1 v2)
+ | Odivfs, v1::v2::nil => Some(Val.divfs v1 v2)
+ | Osingleoffloat, v1::nil => Some(Val.singleoffloat v1)
+ | Ofloatofsingle, v1::nil => Some(Val.floatofsingle v1)
+ | Ointoffloat, v1::nil => Val.intoffloat v1
+ | Ofloatofint, v1::nil => Val.floatofint v1
+ | Ointofsingle, v1::nil => Val.intofsingle v1
+ | Osingleofint, v1::nil => Val.singleofint v1
+ | Olongoffloat, v1::nil => Val.longoffloat v1
+ | Ofloatoflong, v1::nil => Val.floatoflong v1
+ | Olongofsingle, v1::nil => Val.longofsingle v1
+ | Osingleoflong, v1::nil => Val.singleoflong v1
+ | Ocmp c, _ => Some(Val.of_optbool (eval_condition c vl m))
+ | _, _ => None
+ end.
+
+Remark eval_addressing_Aglobal:
+ forall (F V: Type) (genv: Genv.t F V) sp id ofs,
+ eval_addressing genv sp (Aglobal id ofs) nil = Some (Genv.symbol_address genv id ofs).
+Proof.
+ intros. unfold eval_addressing, eval_addressing32, eval_addressing64; destruct Archi.ptr64; auto.
+Qed.
+
+Remark eval_addressing_Ainstack:
+ forall (F V: Type) (genv: Genv.t F V) sp ofs,
+ eval_addressing genv sp (Ainstack ofs) nil = Some (Val.offset_ptr sp ofs).
+Proof.
+ intros. unfold eval_addressing, eval_addressing32, eval_addressing64; destruct Archi.ptr64; auto.
+Qed.
+
+Remark eval_addressing_Ainstack_inv:
+ forall (F V: Type) (genv: Genv.t F V) sp ofs vl v,
+ eval_addressing genv sp (Ainstack ofs) vl = Some v -> vl = nil /\ v = Val.offset_ptr sp ofs.
+Proof.
+ unfold eval_addressing, eval_addressing32, eval_addressing64;
+ intros; destruct Archi.ptr64; destruct vl; inv H; auto.
+Qed.
+
+Ltac FuncInv :=
+ match goal with
+ | H: (match ?x with nil => _ | _ :: _ => _ end = Some _) |- _ =>
+ destruct x; simpl in H; FuncInv
+ | H: (match ?v with Vundef => _ | Vint _ => _ | Vfloat _ => _ | Vptr _ _ => _ end = Some _) |- _ =>
+ destruct v; simpl in H; FuncInv
+ | H: (if Archi.ptr64 then _ else _) = Some _ |- _ =>
+ destruct Archi.ptr64 eqn:?; FuncInv
+ | H: (Some _ = Some _) |- _ =>
+ injection H; intros; clear H; FuncInv
+ | H: (None = Some _) |- _ =>
+ discriminate H
+ | _ =>
+ idtac
+ end.
+
+(** * 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
+ | Ccompl _ => Tlong :: Tlong :: nil
+ | Ccomplu _ => Tlong :: Tlong :: nil
+ | Ccomplimm _ _ => Tlong :: nil
+ | Ccompluimm _ _ => Tlong :: nil
+ | Ccompf _ => Tfloat :: Tfloat :: nil
+ | Cnotcompf _ => Tfloat :: Tfloat :: nil
+ | Ccompfs _ => Tsingle :: Tsingle :: nil
+ | Cnotcompfs _ => Tsingle :: Tsingle :: nil
+ | Cmaskzero _ => Tint :: nil
+ | Cmasknotzero _ => Tint :: nil
+ end.
+
+Definition type_of_addressing_gen (tyA: typ) (addr: addressing): list typ :=
+ match addr with
+ | Aindexed _ => tyA :: nil
+ | Aindexed2 _ => tyA :: tyA :: nil
+ | Ascaled _ _ => tyA :: nil
+ | Aindexed2scaled _ _ => tyA :: tyA :: nil
+ | Aglobal _ _ => nil
+ | Abased _ _ => tyA :: nil
+ | Abasedscaled _ _ _ => tyA :: nil
+ | Ainstack _ => nil
+ end.
+
+Definition type_of_addressing := type_of_addressing_gen Tptr.
+Definition type_of_addressing32 := type_of_addressing_gen Tint.
+Definition type_of_addressing64 := type_of_addressing_gen Tlong.
+
+Definition type_of_operation (op: operation) : list typ * typ :=
+ match op with
+ | Omove => (nil, Tint) (* treated specially *)
+ | Ointconst _ => (nil, Tint)
+ | Olongconst _ => (nil, Tlong)
+ | Ofloatconst f => (nil, Tfloat)
+ | Osingleconst f => (nil, Tsingle)
+ | Oindirectsymbol _ => (nil, Tptr)
+ | Ocast8signed => (Tint :: nil, Tint)
+ | Ocast8unsigned => (Tint :: nil, Tint)
+ | Ocast16signed => (Tint :: nil, Tint)
+ | Ocast16unsigned => (Tint :: nil, Tint)
+ | Oneg => (Tint :: nil, Tint)
+ | Osub => (Tint :: Tint :: nil, Tint)
+ | Omul => (Tint :: Tint :: nil, Tint)
+ | Omulimm _ => (Tint :: nil, Tint)
+ | Omulhs => (Tint :: Tint :: nil, Tint)
+ | Omulhu => (Tint :: Tint :: nil, Tint)
+ | Odiv => (Tint :: Tint :: nil, Tint)
+ | Odivu => (Tint :: Tint :: nil, Tint)
+ | Omod => (Tint :: Tint :: nil, Tint)
+ | Omodu => (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)
+ | Onot => (Tint :: nil, Tint)
+ | Oshl => (Tint :: Tint :: nil, Tint)
+ | Oshlimm _ => (Tint :: nil, Tint)
+ | Oshr => (Tint :: Tint :: nil, Tint)
+ | Oshrimm _ => (Tint :: nil, Tint)
+ | Oshrximm _ => (Tint :: nil, Tint)
+ | Oshru => (Tint :: Tint :: nil, Tint)
+ | Oshruimm _ => (Tint :: nil, Tint)
+ | Ororimm _ => (Tint :: nil, Tint)
+ | Oshldimm _ => (Tint :: Tint :: nil, Tint)
+ | Olea addr => (type_of_addressing32 addr, Tint)
+ | Omakelong => (Tint :: Tint :: nil, Tlong)
+ | Olowlong => (Tlong :: nil, Tint)
+ | Ohighlong => (Tlong :: nil, Tint)
+ | Ocast32signed => (Tint :: nil, Tlong)
+ | Ocast32unsigned => (Tint :: nil, Tlong)
+ | Onegl => (Tlong :: nil, Tlong)
+ | Oaddlimm _ => (Tlong :: nil, Tlong)
+ | Osubl => (Tlong :: Tlong :: nil, Tlong)
+ | Omull => (Tlong :: Tlong :: nil, Tlong)
+ | Omullimm _ => (Tlong :: nil, Tlong)
+ | Omullhs => (Tlong :: Tlong :: nil, Tlong)
+ | Omullhu => (Tlong :: Tlong :: nil, Tlong)
+ | Odivl => (Tlong :: Tlong :: nil, Tlong)
+ | Odivlu => (Tlong :: Tlong :: nil, Tlong)
+ | Omodl => (Tlong :: Tlong :: nil, Tlong)
+ | Omodlu => (Tlong :: Tlong :: nil, Tlong)
+ | Oandl => (Tlong :: Tlong :: nil, Tlong)
+ | Oandlimm _ => (Tlong :: nil, Tlong)
+ | Oorl => (Tlong :: Tlong :: nil, Tlong)
+ | Oorlimm _ => (Tlong :: nil, Tlong)
+ | Oxorl => (Tlong :: Tlong :: nil, Tlong)
+ | Oxorlimm _ => (Tlong :: nil, Tlong)
+ | Onotl => (Tlong :: nil, Tlong)
+ | Oshll => (Tlong :: Tint :: nil, Tlong)
+ | Oshllimm _ => (Tlong :: nil, Tlong)
+ | Oshrl => (Tlong :: Tint :: nil, Tlong)
+ | Oshrlimm _ => (Tlong :: nil, Tlong)
+ | Oshrxlimm _ => (Tlong :: nil, Tlong)
+ | Oshrlu => (Tlong :: Tint :: nil, Tlong)
+ | Oshrluimm _ => (Tlong :: nil, Tlong)
+ | Ororlimm _ => (Tlong :: nil, Tlong)
+ | Oleal addr => (type_of_addressing64 addr, Tlong)
+ | 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)
+ | Onegfs => (Tsingle :: nil, Tsingle)
+ | Oabsfs => (Tsingle :: nil, Tsingle)
+ | Oaddfs => (Tsingle :: Tsingle :: nil, Tsingle)
+ | Osubfs => (Tsingle :: Tsingle :: nil, Tsingle)
+ | Omulfs => (Tsingle :: Tsingle :: nil, Tsingle)
+ | Odivfs => (Tsingle :: Tsingle :: nil, Tsingle)
+ | Osingleoffloat => (Tfloat :: nil, Tsingle)
+ | Ofloatofsingle => (Tsingle :: nil, Tfloat)
+ | Ointoffloat => (Tfloat :: nil, Tint)
+ | Ofloatofint => (Tint :: nil, Tfloat)
+ | Ointofsingle => (Tsingle :: nil, Tint)
+ | Osingleofint => (Tint :: nil, Tsingle)
+ | Olongoffloat => (Tfloat :: nil, Tlong)
+ | Ofloatoflong => (Tlong :: nil, Tfloat)
+ | Olongofsingle => (Tsingle :: nil, Tlong)
+ | Osingleoflong => (Tlong :: nil, Tsingle)
+ | Ocmp c => (type_of_condition c, Tint)
+ 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 V: Type.
+Variable genv: Genv.t A V.
+
+Remark type_add:
+ forall v1 v2, Val.has_type (Val.add v1 v2) Tint.
+Proof.
+ intros. unfold Val.has_type, Val.add. destruct Archi.ptr64, v1, v2; auto.
+Qed.
+
+Remark type_addl:
+ forall v1 v2, Val.has_type (Val.addl v1 v2) Tlong.
+Proof.
+ intros. unfold Val.has_type, Val.addl. destruct Archi.ptr64, v1, v2; auto.
+Qed.
+
+Lemma type_of_addressing64_sound:
+ forall addr vl sp v,
+ eval_addressing64 genv sp addr vl = Some v ->
+ Val.has_type v Tlong.
+Proof.
+ intros. destruct addr; simpl in H; FuncInv; subst; simpl; auto using type_addl.
+- unfold Genv.symbol_address; destruct (Genv.find_symbol genv i); simpl; auto.
+- destruct sp; simpl; auto.
+Qed.
+
+Lemma type_of_addressing32_sound:
+ forall addr vl sp v,
+ eval_addressing32 genv sp addr vl = Some v ->
+ Val.has_type v Tint.
+Proof.
+ intros. destruct addr; simpl in H; FuncInv; subst; simpl; auto using type_add.
+- unfold Genv.symbol_address; destruct (Genv.find_symbol genv i); simpl; auto.
+- destruct sp; simpl; auto.
+Qed.
+
+Corollary type_of_addressing_sound:
+ forall addr vl sp v,
+ eval_addressing genv sp addr vl = Some v ->
+ Val.has_type v Tptr.
+Proof.
+ unfold eval_addressing, Tptr; intros.
+ destruct Archi.ptr64; eauto using type_of_addressing64_sound, type_of_addressing32_sound.
+Qed.
+
+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 with (try exact I; try reflexivity).
+ intros.
+ destruct op; simpl in H0; FuncInv; subst; simpl.
+ congruence.
+ exact I.
+ exact I.
+ exact I.
+ exact I.
+ unfold Genv.symbol_address; destruct (Genv.find_symbol genv id)...
+ destruct v0...
+ destruct v0...
+ destruct v0...
+ destruct v0...
+ destruct v0...
+ unfold Val.sub, Val.has_type; destruct Archi.ptr64, v0, v1... destruct (eq_block b b0)...
+ destruct v0; destruct v1...
+ destruct v0...
+ destruct v0; destruct v1...
+ destruct v0; destruct v1...
+ destruct v0; destruct v1; simpl in *; inv H0.
+ destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2...
+ destruct v0; destruct v1; simpl in *; inv H0. destruct (Int.eq i0 Int.zero); inv H2...
+ destruct v0; destruct v1; simpl in *; inv H0.
+ destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2...
+ destruct v0; destruct v1; simpl in *; inv H0. destruct (Int.eq i0 Int.zero); inv H2...
+ destruct v0; destruct v1...
+ destruct v0...
+ destruct v0; destruct v1...
+ destruct v0...
+ destruct v0; destruct v1...
+ destruct v0...
+ destruct v0...
+ destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)...
+ destruct v0; simpl... destruct (Int.ltu n Int.iwordsize)...
+ destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)...
+ destruct v0; simpl... destruct (Int.ltu n Int.iwordsize)...
+ destruct v0; simpl in H0; try discriminate. destruct (Int.ltu n (Int.repr 31)); inv H0...
+ destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)...
+ destruct v0; simpl... destruct (Int.ltu n Int.iwordsize)...
+ destruct v0...
+ destruct v0; simpl... destruct (Int.ltu n Int.iwordsize)...
+ destruct v1; simpl... destruct (Int.ltu (Int.sub Int.iwordsize n) Int.iwordsize)...
+ eapply type_of_addressing32_sound; eauto.
+ destruct v0; destruct v1...
+ destruct v0...
+ destruct v0...
+ destruct v0...
+ destruct v0...
+ destruct v0...
+ unfold Val.addl, Val.has_type; destruct Archi.ptr64, v0...
+ unfold Val.subl, Val.has_type; destruct Archi.ptr64, v0, v1... destruct (eq_block b b0)...
+ destruct v0; destruct v1...
+ destruct v0...
+ destruct v0; destruct v1...
+ destruct v0; destruct v1...
+ destruct v0; destruct v1; simpl in *; inv H0.
+ destruct (Int64.eq i0 Int64.zero || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2...
+ destruct v0; destruct v1; simpl in *; inv H0. destruct (Int64.eq i0 Int64.zero); inv H2...
+ destruct v0; destruct v1; simpl in *; inv H0.
+ destruct (Int64.eq i0 Int64.zero || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2...
+ destruct v0; destruct v1; simpl in *; inv H0. destruct (Int64.eq i0 Int64.zero); inv H2...
+ destruct v0; destruct v1...
+ destruct v0...
+ destruct v0; destruct v1...
+ destruct v0...
+ destruct v0; destruct v1...
+ destruct v0...
+ destruct v0...
+ destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')...
+ destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')...
+ destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')...
+ destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')...
+ destruct v0; inv H0. destruct (Int.ltu n (Int.repr 63)); inv H2...
+ destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')...
+ destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')...
+ destruct v0...
+ eapply type_of_addressing64_sound; eauto.
+ destruct v0...
+ destruct v0...
+ destruct v0; destruct v1...
+ destruct v0; destruct v1...
+ destruct v0; destruct v1...
+ destruct v0; destruct v1...
+ destruct v0...
+ destruct v0...
+ destruct v0; destruct v1...
+ destruct v0; destruct v1...
+ destruct v0; destruct v1...
+ destruct v0; destruct v1...
+ destruct v0...
+ destruct v0...
+ destruct v0; simpl in H0; inv H0. destruct (Float.to_int f); inv H2...
+ destruct v0; simpl in H0; inv H0...
+ destruct v0; simpl in H0; inv H0. destruct (Float32.to_int f); inv H2...
+ destruct v0; simpl in H0; inv H0...
+ destruct v0; simpl in H0; inv H0. destruct (Float.to_long f); inv H2...
+ destruct v0; simpl in H0; inv H0...
+ destruct v0; simpl in H0; inv H0. destruct (Float32.to_long f); inv H2...
+ destruct v0; simpl in H0; inv H0...
+ destruct (eval_condition cond vl m); simpl... destruct b...
+Qed.
+
+End SOUNDNESS.
+
+(** * Manipulating and transforming operations *)
+
+(** Recognition of move operations. *)
+
+Definition is_move_operation
+ (A: Type) (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: Type) (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.
+
+(** [negate_condition cond] returns a condition that is logically
+ equivalent to the negation of [cond]. *)
+
+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
+ | Ccompl c => Ccompl(negate_comparison c)
+ | Ccomplu c => Ccomplu(negate_comparison c)
+ | Ccomplimm c n => Ccomplimm (negate_comparison c) n
+ | Ccompluimm c n => Ccompluimm (negate_comparison c) n
+ | Ccompf c => Cnotcompf c
+ | Cnotcompf c => Ccompf c
+ | Ccompfs c => Cnotcompfs c
+ | Cnotcompfs c => Ccompfs c
+ | Cmaskzero n => Cmasknotzero n
+ | Cmasknotzero n => Cmaskzero n
+ end.
+
+Lemma eval_negate_condition:
+ forall cond vl m,
+ eval_condition (negate_condition cond) vl m = option_map negb (eval_condition cond vl m).
+Proof.
+ intros. destruct cond; simpl.
+ repeat (destruct vl; auto). apply Val.negate_cmp_bool.
+ repeat (destruct vl; auto). apply Val.negate_cmpu_bool.
+ repeat (destruct vl; auto). apply Val.negate_cmp_bool.
+ repeat (destruct vl; auto). apply Val.negate_cmpu_bool.
+ repeat (destruct vl; auto). apply Val.negate_cmpl_bool.
+ repeat (destruct vl; auto). apply Val.negate_cmplu_bool.
+ repeat (destruct vl; auto). apply Val.negate_cmpl_bool.
+ repeat (destruct vl; auto). apply Val.negate_cmplu_bool.
+ repeat (destruct vl; auto).
+ repeat (destruct vl; auto). destruct (Val.cmpf_bool c v v0) as [[]|]; auto.
+ repeat (destruct vl; auto).
+ repeat (destruct vl; auto). destruct (Val.cmpfs_bool c v v0) as [[]|]; auto.
+ destruct vl; auto. destruct vl; auto.
+ destruct vl; auto. destruct vl; auto. destruct (Val.maskzero_bool v n) as [[]|]; auto.
+Qed.
+
+(** Shifting stack-relative references. This is used in [Stacking]. *)
+
+Definition shift_stack_addressing (delta: Z) (addr: addressing) :=
+ match addr with
+ | Ainstack ofs => Ainstack (Ptrofs.add ofs (Ptrofs.repr delta))
+ | _ => addr
+ end.
+
+Definition shift_stack_operation (delta: Z) (op: operation) :=
+ match op with
+ | Olea addr => Olea (shift_stack_addressing delta addr)
+ | Oleal addr => Oleal (shift_stack_addressing delta addr)
+ | _ => op
+ end.
+
+Lemma type_shift_stack_addressing:
+ forall delta addr, type_of_addressing (shift_stack_addressing delta addr) = type_of_addressing addr.
+Proof.
+ intros. destruct addr; auto.
+Qed.
+
+Lemma type_shift_stack_operation:
+ forall delta op, type_of_operation (shift_stack_operation delta op) = type_of_operation op.
+Proof.
+ intros. destruct op; auto; simpl; decEq; destruct a; auto.
+Qed.
+
+Lemma eval_shift_stack_addressing32:
+ forall F V (ge: Genv.t F V) sp addr vl delta,
+ eval_addressing32 ge (Vptr sp Ptrofs.zero) (shift_stack_addressing delta addr) vl =
+ eval_addressing32 ge (Vptr sp (Ptrofs.repr delta)) addr vl.
+Proof.
+ intros.
+ assert (A: forall i, Ptrofs.add Ptrofs.zero (Ptrofs.add i (Ptrofs.repr delta)) = Ptrofs.add (Ptrofs.repr delta) i).
+ { intros. rewrite Ptrofs.add_zero_l. apply Ptrofs.add_commut. }
+ destruct addr; simpl; rewrite ?A; reflexivity.
+Qed.
+
+Lemma eval_shift_stack_addressing64:
+ forall F V (ge: Genv.t F V) sp addr vl delta,
+ eval_addressing64 ge (Vptr sp Ptrofs.zero) (shift_stack_addressing delta addr) vl =
+ eval_addressing64 ge (Vptr sp (Ptrofs.repr delta)) addr vl.
+Proof.
+ intros.
+ assert (A: forall i, Ptrofs.add Ptrofs.zero (Ptrofs.add i (Ptrofs.repr delta)) = Ptrofs.add (Ptrofs.repr delta) i).
+ { intros. rewrite Ptrofs.add_zero_l. apply Ptrofs.add_commut. }
+ destruct addr; simpl; rewrite ?A; reflexivity.
+Qed.
+
+Lemma eval_shift_stack_addressing:
+ forall F V (ge: Genv.t F V) sp addr vl delta,
+ eval_addressing ge (Vptr sp Ptrofs.zero) (shift_stack_addressing delta addr) vl =
+ eval_addressing ge (Vptr sp (Ptrofs.repr delta)) addr vl.
+Proof.
+ intros. unfold eval_addressing.
+ destruct Archi.ptr64; auto using eval_shift_stack_addressing32, eval_shift_stack_addressing64.
+Qed.
+
+Lemma eval_shift_stack_operation:
+ forall F V (ge: Genv.t F V) sp op vl m delta,
+ eval_operation ge (Vptr sp Ptrofs.zero) (shift_stack_operation delta op) vl m =
+ eval_operation ge (Vptr sp (Ptrofs.repr delta)) op vl m.
+Proof.
+ intros. destruct op; simpl; auto using eval_shift_stack_addressing32, eval_shift_stack_addressing64.
+Qed.
+
+(** Offset an addressing mode [addr] by a quantity [delta], so that
+ it designates the pointer [delta] bytes past the pointer designated
+ by [addr]. This may be undefined if an offset overflows, in which case
+ [None] is returned. *)
+
+Definition offset_addressing_total (addr: addressing) (delta: Z) : addressing :=
+ match addr with
+ | Aindexed n => Aindexed (n + delta)
+ | Aindexed2 n => Aindexed2 (n + delta)
+ | Ascaled sc n => Ascaled sc (n + delta)
+ | Aindexed2scaled sc n => Aindexed2scaled sc (n + delta)
+ | Aglobal s n => Aglobal s (Ptrofs.add n (Ptrofs.repr delta))
+ | Abased s n => Abased s (Ptrofs.add n (Ptrofs.repr delta))
+ | Abasedscaled sc s n => Abasedscaled sc s (Ptrofs.add n (Ptrofs.repr delta))
+ | Ainstack n => Ainstack (Ptrofs.add n (Ptrofs.repr delta))
+ end.
+
+Definition offset_addressing (addr: addressing) (delta: Z) : option addressing :=
+ let addr' := offset_addressing_total addr delta in
+ if addressing_valid addr' then Some addr' else None.
+
+Lemma eval_offset_addressing_total_32:
+ forall (F V: Type) (ge: Genv.t F V) sp addr args delta v,
+ eval_addressing32 ge sp addr args = Some v ->
+ eval_addressing32 ge sp (offset_addressing_total addr delta) args = Some(Val.add v (Vint (Int.repr delta))).
+Proof.
+ assert (A: forall x y, Int.add (Int.repr x) (Int.repr y) = Int.repr (x + y)).
+ { intros. apply Int.eqm_samerepr; auto with ints. }
+ assert (B: forall delta, Archi.ptr64 = false -> Ptrofs.repr delta = Ptrofs.of_int (Int.repr delta)).
+ { intros; symmetry; auto with ptrofs. }
+ intros. destruct addr; simpl in *; FuncInv; subst; simpl.
+- rewrite <- A, ! Val.add_assoc; auto.
+- rewrite <- A, ! Val.add_assoc; auto.
+- rewrite <- A, ! Val.add_assoc; auto.
+- rewrite <- A, ! Val.add_assoc; auto.
+- rewrite B, Genv.shift_symbol_address_32 by auto. auto.
+- rewrite B, Genv.shift_symbol_address_32 by auto. rewrite ! Val.add_assoc. do 2 f_equal. apply Val.add_commut.
+- rewrite B, Genv.shift_symbol_address_32 by auto. rewrite ! Val.add_assoc. do 2 f_equal. apply Val.add_commut.
+- destruct sp; simpl; auto. rewrite Heqb. rewrite Ptrofs.add_assoc. do 4 f_equal. symmetry; auto with ptrofs.
+Qed.
+
+Lemma eval_offset_addressing_total_64:
+ forall (F V: Type) (ge: Genv.t F V) sp addr args delta v,
+ eval_addressing64 ge sp addr args = Some v ->
+ eval_addressing64 ge sp (offset_addressing_total addr delta) args = Some(Val.addl v (Vlong (Int64.repr delta))).
+Proof.
+ assert (A: forall x y, Int64.add (Int64.repr x) (Int64.repr y) = Int64.repr (x + y)).
+ { intros. apply Int64.eqm_samerepr; auto with ints. }
+ assert (B: forall delta, Archi.ptr64 = true -> Ptrofs.repr delta = Ptrofs.of_int64 (Int64.repr delta)).
+ { intros; symmetry; auto with ptrofs. }
+ intros. destruct addr; simpl in *; FuncInv; subst; simpl.
+- rewrite <- A, ! Val.addl_assoc; auto.
+- rewrite <- A, ! Val.addl_assoc; auto.
+- rewrite <- A, ! Val.addl_assoc; auto.
+- rewrite <- A, ! Val.addl_assoc; auto.
+- rewrite B, Genv.shift_symbol_address_64 by auto. auto.
+- destruct sp; simpl; auto. rewrite Heqb. rewrite Ptrofs.add_assoc. do 4 f_equal. symmetry; auto with ptrofs.
+Qed.
+
+(** The following lemma is used only in [Allocproof] in cases where [Archi.ptr64 = false]. *)
+
+Lemma eval_offset_addressing:
+ forall (F V: Type) (ge: Genv.t F V) sp addr args delta addr' v,
+ offset_addressing addr delta = Some addr' ->
+ eval_addressing ge sp addr args = Some v ->
+ Archi.ptr64 = false ->
+ eval_addressing ge sp addr' args = Some(Val.add v (Vint (Int.repr delta))).
+Proof.
+ intros. unfold offset_addressing in H. destruct (addressing_valid (offset_addressing_total addr delta)); inv H.
+ unfold eval_addressing in *; rewrite H1 in *. apply eval_offset_addressing_total_32; auto.
+Qed.
+
+(** Operations that are so cheap to recompute that CSE should not factor them out. *)
+
+Definition is_trivial_op (op: operation) : bool :=
+ match op with
+ | Omove => true
+ | Ointconst _ => true
+ | Olongconst _ => true
+ | Olea (Aglobal _ _) => true
+ | Olea (Ainstack _) => true
+ | Oleal (Aglobal _ _) => true
+ | Oleal (Ainstack _) => true
+ | _ => false
+ end.
+
+(** Operations that depend on the memory state. *)
+
+Definition op_depends_on_memory (op: operation) : bool :=
+ match op with
+ | Ocmp (Ccompu _) => negb Archi.ptr64
+ | Ocmp (Ccompuimm _ _) => negb Archi.ptr64
+ | Ocmp (Ccomplu _) => Archi.ptr64
+ | Ocmp (Ccompluimm _ _) => Archi.ptr64
+ | _ => false
+ end.
+
+Lemma op_depends_on_memory_correct:
+ forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2,
+ op_depends_on_memory op = false ->
+ eval_operation ge sp op args m1 = eval_operation ge sp op args m2.
+Proof.
+ intros until m2. destruct op; simpl; try congruence.
+ destruct cond; simpl; intros SF; auto; rewrite ? negb_false_iff in SF;
+ unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity.
+Qed.
+
+(** Global variables mentioned in an operation or addressing mode *)
+
+Definition globals_addressing (addr: addressing) : list ident :=
+ match addr with
+ | Aglobal s n => s :: nil
+ | Abased s n => s :: nil
+ | Abasedscaled sc s n => s :: nil
+ | _ => nil
+ end.
+
+Definition globals_operation (op: operation) : list ident :=
+ match op with
+ | Oindirectsymbol s => s :: nil
+ | Olea addr => globals_addressing addr
+ | Oleal addr => globals_addressing addr
+ | _ => nil
+ end.
+
+(** * Invariance and compatibility properties. *)
+
+(** [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 V1 V2: Type.
+Variable ge1: Genv.t F1 V1.
+Variable ge2: Genv.t F2 V2.
+Hypothesis agree_on_symbols:
+ forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s.
+
+Lemma eval_addressing32_preserved:
+ forall sp addr vl,
+ eval_addressing32 ge2 sp addr vl = eval_addressing32 ge1 sp addr vl.
+Proof.
+ intros.
+ unfold eval_addressing32, Genv.symbol_address; destruct addr; try rewrite agree_on_symbols;
+ reflexivity.
+Qed.
+
+Lemma eval_addressing64_preserved:
+ forall sp addr vl,
+ eval_addressing64 ge2 sp addr vl = eval_addressing64 ge1 sp addr vl.
+Proof.
+ intros.
+ unfold eval_addressing64, Genv.symbol_address; destruct addr; 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 Archi.ptr64; auto using eval_addressing32_preserved, eval_addressing64_preserved.
+Qed.
+
+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; auto using eval_addressing32_preserved, eval_addressing64_preserved.
+ unfold Genv.symbol_address. rewrite agree_on_symbols. auto.
+Qed.
+
+End GENV_TRANSF.
+
+(** Compatibility of the evaluation functions with value injections. *)
+
+Section EVAL_COMPAT.
+
+Variable F1 F2 V1 V2: Type.
+Variable ge1: Genv.t F1 V1.
+Variable ge2: Genv.t F2 V2.
+Variable f: meminj.
+
+Variable m1: mem.
+Variable m2: mem.
+
+Hypothesis valid_pointer_inj:
+ forall b1 ofs b2 delta,
+ f b1 = Some(b2, delta) ->
+ Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true ->
+ Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true.
+
+Hypothesis weak_valid_pointer_inj:
+ forall b1 ofs b2 delta,
+ f b1 = Some(b2, delta) ->
+ Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true ->
+ Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true.
+
+Hypothesis weak_valid_pointer_no_overflow:
+ forall b1 ofs b2 delta,
+ f b1 = Some(b2, delta) ->
+ Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true ->
+ 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned.
+
+Hypothesis valid_different_pointers_inj:
+ forall b1 ofs1 b2 ofs2 b1' delta1 b2' delta2,
+ b1 <> b2 ->
+ Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true ->
+ Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true ->
+ f b1 = Some (b1', delta1) ->
+ f b2 = Some (b2', delta2) ->
+ b1' <> b2' \/
+ Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned (Ptrofs.add ofs2 (Ptrofs.repr delta2)).
+
+Ltac InvInject :=
+ match goal with
+ | [ H: Val.inject _ (Vint _) _ |- _ ] =>
+ inv H; InvInject
+ | [ H: Val.inject _ (Vfloat _) _ |- _ ] =>
+ inv H; InvInject
+ | [ H: Val.inject _ (Vptr _ _) _ |- _ ] =>
+ inv H; InvInject
+ | [ H: Val.inject_list _ nil _ |- _ ] =>
+ inv H; InvInject
+ | [ H: Val.inject_list _ (_ :: _) _ |- _ ] =>
+ inv H; InvInject
+ | _ => idtac
+ end.
+
+Lemma eval_condition_inj:
+ forall cond vl1 vl2 b,
+ Val.inject_list f vl1 vl2 ->
+ eval_condition cond vl1 m1 = Some b ->
+ eval_condition cond vl2 m2 = Some b.
+Proof.
+ intros. destruct cond; simpl in H0; FuncInv; InvInject; simpl; auto.
+- inv H3; inv H2; simpl in H0; inv H0; auto.
+- eauto 3 using Val.cmpu_bool_inject, Mem.valid_pointer_implies.
+- inv H3; simpl in H0; inv H0; auto.
+- eauto 3 using Val.cmpu_bool_inject, Mem.valid_pointer_implies.
+- inv H3; inv H2; simpl in H0; inv H0; auto.
+- eauto 3 using Val.cmplu_bool_inject, Mem.valid_pointer_implies.
+- inv H3; simpl in H0; inv H0; auto.
+- eauto 3 using Val.cmplu_bool_inject, Mem.valid_pointer_implies.
+- inv H3; inv H2; simpl in H0; inv H0; auto.
+- inv H3; inv H2; simpl in H0; inv H0; auto.
+- inv H3; inv H2; simpl in H0; inv H0; auto.
+- inv H3; inv H2; simpl in H0; inv H0; auto.
+- inv H3; try discriminate; auto.
+- inv H3; try discriminate; auto.
+Qed.
+
+Ltac TrivialExists :=
+ match goal with
+ | [ |- exists v2, Some ?v1 = Some v2 /\ Val.inject _ _ v2 ] =>
+ exists v1; split; auto
+ | _ => idtac
+ end.
+
+Lemma eval_addressing32_inj:
+ forall addr sp1 vl1 sp2 vl2 v1,
+ (forall id ofs,
+ In id (globals_addressing addr) ->
+ Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) ->
+ Val.inject f sp1 sp2 ->
+ Val.inject_list f vl1 vl2 ->
+ eval_addressing32 ge1 sp1 addr vl1 = Some v1 ->
+ exists v2, eval_addressing32 ge2 sp2 addr vl2 = Some v2 /\ Val.inject f v1 v2.
+Proof.
+ assert (A: forall v1 v2 v1' v2', Val.inject f v1 v1' -> Val.inject f v2 v2' -> Val.inject f (Val.mul v1 v2) (Val.mul v1' v2')).
+ { intros. inv H; simpl; auto. inv H0; auto. }
+ intros. destruct addr; simpl in *; FuncInv; InvInject; TrivialExists; eauto using Val.add_inject, Val.offset_ptr_inject with coqlib.
+Qed.
+
+Lemma eval_addressing64_inj:
+ forall addr sp1 vl1 sp2 vl2 v1,
+ (forall id ofs,
+ In id (globals_addressing addr) ->
+ Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) ->
+ Val.inject f sp1 sp2 ->
+ Val.inject_list f vl1 vl2 ->
+ eval_addressing64 ge1 sp1 addr vl1 = Some v1 ->
+ exists v2, eval_addressing64 ge2 sp2 addr vl2 = Some v2 /\ Val.inject f v1 v2.
+Proof.
+ assert (A: forall v1 v2 v1' v2', Val.inject f v1 v1' -> Val.inject f v2 v2' -> Val.inject f (Val.mull v1 v2) (Val.mull v1' v2')).
+ { intros. inv H; simpl; auto. inv H0; auto. }
+ intros. destruct addr; simpl in *; FuncInv; InvInject; TrivialExists; eauto using Val.addl_inject, Val.offset_ptr_inject with coqlib.
+Qed.
+
+Lemma eval_addressing_inj:
+ forall addr sp1 vl1 sp2 vl2 v1,
+ (forall id ofs,
+ In id (globals_addressing addr) ->
+ Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) ->
+ Val.inject f sp1 sp2 ->
+ Val.inject_list f vl1 vl2 ->
+ eval_addressing ge1 sp1 addr vl1 = Some v1 ->
+ exists v2, eval_addressing ge2 sp2 addr vl2 = Some v2 /\ Val.inject f v1 v2.
+Proof.
+ unfold eval_addressing; intros. destruct Archi.ptr64; eauto using eval_addressing32_inj, eval_addressing64_inj.
+Qed.
+
+Lemma eval_operation_inj:
+ forall op sp1 vl1 sp2 vl2 v1,
+ (forall id ofs,
+ In id (globals_operation op) ->
+ Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) ->
+ Val.inject f sp1 sp2 ->
+ Val.inject_list f vl1 vl2 ->
+ eval_operation ge1 sp1 op vl1 m1 = Some v1 ->
+ exists v2, eval_operation ge2 sp2 op vl2 m2 = Some v2 /\ Val.inject f v1 v2.
+Proof.
+ intros until v1; intros GL; intros. destruct op; simpl in H1; simpl; FuncInv; InvInject; TrivialExists.
+ apply GL; simpl; auto.
+ inv H4; simpl; auto.
+ inv H4; simpl; auto.
+ inv H4; simpl; auto.
+ inv H4; simpl; auto.
+ inv H4; simpl; auto.
+ apply Val.sub_inject; auto.
+ inv H4; inv H2; simpl; auto.
+ inv H4; simpl; auto.
+ inv H4; inv H2; simpl; auto.
+ inv H4; inv H2; simpl; auto.
+ inv H4; inv H3; simpl in H1; inv H1. simpl.
+ destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2. TrivialExists.
+ inv H4; inv H3; simpl in H1; inv H1. simpl.
+ destruct (Int.eq i0 Int.zero); inv H2. TrivialExists.
+ inv H4; inv H3; simpl in H1; inv H1. simpl.
+ destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2. TrivialExists.
+ inv H4; inv H3; simpl in H1; inv H1. simpl.
+ destruct (Int.eq i0 Int.zero); inv H2. TrivialExists.
+ inv H4; inv H2; simpl; auto.
+ inv H4; simpl; auto.
+ inv H4; inv H2; simpl; auto.
+ inv H4; simpl; auto.
+ inv H4; inv H2; simpl; auto.
+ inv H4; simpl; auto.
+ inv H4; simpl; auto.
+ inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto.
+ inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto.
+ inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto.
+ inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto.
+ inv H4; simpl in H1; try discriminate. simpl.
+ destruct (Int.ltu n (Int.repr 31)); inv H1. TrivialExists.
+ inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto.
+ inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto.
+ inv H4; simpl; auto.
+ inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto.
+ inv H2; simpl; auto. destruct (Int.ltu (Int.sub Int.iwordsize n) Int.iwordsize); auto.
+ eapply eval_addressing32_inj; eauto.
+ inv H4; inv H2; simpl; auto.
+ inv H4; simpl; auto.
+ inv H4; simpl; auto.
+ inv H4; simpl; auto.
+ inv H4; simpl; auto.
+ inv H4; simpl; auto.
+ apply Val.addl_inject; auto.
+ apply Val.subl_inject; auto.
+ inv H4; inv H2; simpl; auto.
+ inv H4; simpl; auto.
+ inv H4; inv H2; simpl; auto.
+ inv H4; inv H2; simpl; auto.
+ inv H4; inv H3; simpl in H1; inv H1. simpl.
+ destruct (Int64.eq i0 Int64.zero || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2. TrivialExists.
+ inv H4; inv H3; simpl in H1; inv H1. simpl.
+ destruct (Int64.eq i0 Int64.zero); inv H2. TrivialExists.
+ inv H4; inv H3; simpl in H1; inv H1. simpl.
+ destruct (Int64.eq i0 Int64.zero || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2. TrivialExists.
+ inv H4; inv H3; simpl in H1; inv H1. simpl.
+ destruct (Int64.eq i0 Int64.zero); inv H2. TrivialExists.
+ inv H4; inv H2; simpl; auto.
+ inv H4; simpl; auto.
+ inv H4; inv H2; simpl; auto.
+ inv H4; simpl; auto.
+ inv H4; inv H2; simpl; auto.
+ inv H4; simpl; auto.
+ inv H4; simpl; auto.
+ inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto.
+ inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto.
+ inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto.
+ inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto.
+ inv H4; simpl in H1; try discriminate. simpl. destruct (Int.ltu n (Int.repr 63)); inv H1. TrivialExists.
+ inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto.
+ inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto.
+ inv H4; simpl; auto.
+ eapply eval_addressing64_inj; eauto.
+ inv H4; simpl; auto.
+ inv H4; simpl; auto.
+ inv H4; inv H2; simpl; auto.
+ inv H4; inv H2; simpl; auto.
+ inv H4; inv H2; simpl; auto.
+ inv H4; inv H2; simpl; auto.
+ inv H4; simpl; auto.
+ inv H4; simpl; auto.
+ inv H4; inv H2; simpl; auto.
+ inv H4; inv H2; simpl; auto.
+ inv H4; inv H2; simpl; auto.
+ inv H4; inv H2; simpl; auto.
+ inv H4; simpl; auto.
+ inv H4; simpl; auto.
+ inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_int f0); simpl in H2; inv H2.
+ exists (Vint i); auto.
+ inv H4; simpl in H1; inv H1. simpl. TrivialExists.
+ inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_int f0); simpl in H2; inv H2.
+ exists (Vint i); auto.
+ inv H4; simpl in H1; inv H1. simpl. TrivialExists.
+ inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_long f0); simpl in H2; inv H2.
+ exists (Vlong i); auto.
+ inv H4; simpl in H1; inv H1. simpl. TrivialExists.
+ inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_long f0); simpl in H2; inv H2.
+ exists (Vlong i); auto.
+ inv H4; simpl in H1; inv H1. simpl. TrivialExists.
+ subst v1. destruct (eval_condition cond vl1 m1) eqn:?.
+ exploit eval_condition_inj; eauto. intros EQ; rewrite EQ.
+ destruct b; simpl; constructor.
+ simpl; constructor.
+Qed.
+
+End EVAL_COMPAT.
+
+(** Compatibility of the evaluation functions with the ``is less defined'' relation over values. *)
+
+Section EVAL_LESSDEF.
+
+Variable F V: Type.
+Variable genv: Genv.t F V.
+
+Remark valid_pointer_extends:
+ forall m1 m2, Mem.extends m1 m2 ->
+ forall b1 ofs b2 delta,
+ Some(b1, 0) = Some(b2, delta) ->
+ Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true ->
+ Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true.
+Proof.
+ intros. inv H0. rewrite Ptrofs.add_zero. eapply Mem.valid_pointer_extends; eauto.
+Qed.
+
+Remark weak_valid_pointer_extends:
+ forall m1 m2, Mem.extends m1 m2 ->
+ forall b1 ofs b2 delta,
+ Some(b1, 0) = Some(b2, delta) ->
+ Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true ->
+ Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true.
+Proof.
+ intros. inv H0. rewrite Ptrofs.add_zero. eapply Mem.weak_valid_pointer_extends; eauto.
+Qed.
+
+Remark weak_valid_pointer_no_overflow_extends:
+ forall m1 b1 ofs b2 delta,
+ Some(b1, 0) = Some(b2, delta) ->
+ Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true ->
+ 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned.
+Proof.
+ intros. inv H. rewrite Zplus_0_r. apply Ptrofs.unsigned_range_2.
+Qed.
+
+Remark valid_different_pointers_extends:
+ forall m1 b1 ofs1 b2 ofs2 b1' delta1 b2' delta2,
+ b1 <> b2 ->
+ Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true ->
+ Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true ->
+ Some(b1, 0) = Some (b1', delta1) ->
+ Some(b2, 0) = Some (b2', delta2) ->
+ b1' <> b2' \/
+ Ptrofs.unsigned(Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned(Ptrofs.add ofs2 (Ptrofs.repr delta2)).
+Proof.
+ intros. inv H2; inv H3. auto.
+Qed.
+
+Lemma eval_condition_lessdef:
+ forall cond vl1 vl2 b m1 m2,
+ Val.lessdef_list vl1 vl2 ->
+ Mem.extends m1 m2 ->
+ eval_condition cond vl1 m1 = Some b ->
+ eval_condition cond vl2 m2 = Some b.
+Proof.
+ intros. eapply eval_condition_inj with (f := fun b => Some(b, 0)) (m1 := m1).
+ apply valid_pointer_extends; auto.
+ apply weak_valid_pointer_extends; auto.
+ apply weak_valid_pointer_no_overflow_extends.
+ apply valid_different_pointers_extends; auto.
+ rewrite <- val_inject_list_lessdef. eauto. auto.
+Qed.
+
+Lemma eval_operation_lessdef:
+ forall sp op vl1 vl2 v1 m1 m2,
+ Val.lessdef_list vl1 vl2 ->
+ Mem.extends m1 m2 ->
+ 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. rewrite val_inject_list_lessdef in H.
+ assert (exists v2 : val,
+ eval_operation genv sp op vl2 m2 = Some v2
+ /\ Val.inject (fun b => Some(b, 0)) v1 v2).
+ eapply eval_operation_inj with (m1 := m1) (sp1 := sp).
+ apply valid_pointer_extends; auto.
+ apply weak_valid_pointer_extends; auto.
+ apply weak_valid_pointer_no_overflow_extends.
+ apply valid_different_pointers_extends; auto.
+ intros. apply val_inject_lessdef. auto.
+ apply val_inject_lessdef; auto.
+ eauto.
+ auto.
+ destruct H2 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto.
+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. rewrite val_inject_list_lessdef in H.
+ assert (exists v2 : val,
+ eval_addressing genv sp addr vl2 = Some v2
+ /\ Val.inject (fun b => Some(b, 0)) v1 v2).
+ eapply eval_addressing_inj with (sp1 := sp).
+ intros. rewrite <- val_inject_lessdef; auto.
+ rewrite <- val_inject_lessdef; auto.
+ eauto. auto.
+ destruct H1 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto.
+Qed.
+
+End EVAL_LESSDEF.
+
+(** Compatibility of the evaluation functions with memory injections. *)
+
+Section EVAL_INJECT.
+
+Variable F V: Type.
+Variable genv: Genv.t F V.
+Variable f: meminj.
+Hypothesis globals: meminj_preserves_globals genv f.
+Variable sp1: block.
+Variable sp2: block.
+Variable delta: Z.
+Hypothesis sp_inj: f sp1 = Some(sp2, delta).
+
+Remark symbol_address_inject:
+ forall id ofs, Val.inject f (Genv.symbol_address genv id ofs) (Genv.symbol_address genv id ofs).
+Proof.
+ intros. unfold Genv.symbol_address. destruct (Genv.find_symbol genv id) eqn:?; auto.
+ exploit (proj1 globals); eauto. intros.
+ econstructor; eauto. rewrite Ptrofs.add_zero; auto.
+Qed.
+
+Lemma eval_condition_inject:
+ forall cond vl1 vl2 b m1 m2,
+ Val.inject_list f vl1 vl2 ->
+ Mem.inject f m1 m2 ->
+ eval_condition cond vl1 m1 = Some b ->
+ eval_condition cond vl2 m2 = Some b.
+Proof.
+ intros. eapply eval_condition_inj with (f := f) (m1 := m1); eauto.
+ intros; eapply Mem.valid_pointer_inject_val; eauto.
+ intros; eapply Mem.weak_valid_pointer_inject_val; eauto.
+ intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto.
+ intros; eapply Mem.different_pointers_inject; eauto.
+Qed.
+
+Lemma eval_addressing_inject:
+ forall addr vl1 vl2 v1,
+ Val.inject_list f vl1 vl2 ->
+ eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = Some v1 ->
+ exists v2,
+ eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = Some v2
+ /\ Val.inject f v1 v2.
+Proof.
+ intros.
+ rewrite eval_shift_stack_addressing.
+ eapply eval_addressing_inj with (sp1 := Vptr sp1 Ptrofs.zero); eauto.
+ intros. apply symbol_address_inject.
+ econstructor; eauto. rewrite Ptrofs.add_zero_l; auto.
+Qed.
+
+Lemma eval_operation_inject:
+ forall op vl1 vl2 v1 m1 m2,
+ Val.inject_list f vl1 vl2 ->
+ Mem.inject f m1 m2 ->
+ eval_operation genv (Vptr sp1 Ptrofs.zero) op vl1 m1 = Some v1 ->
+ exists v2,
+ eval_operation genv (Vptr sp2 Ptrofs.zero) (shift_stack_operation delta op) vl2 m2 = Some v2
+ /\ Val.inject f v1 v2.
+Proof.
+ intros.
+ rewrite eval_shift_stack_operation. simpl.
+ eapply eval_operation_inj with (sp1 := Vptr sp1 Ptrofs.zero) (m1 := m1); eauto.
+ intros; eapply Mem.valid_pointer_inject_val; eauto.
+ intros; eapply Mem.weak_valid_pointer_inject_val; eauto.
+ intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto.
+ intros; eapply Mem.different_pointers_inject; eauto.
+ intros. apply symbol_address_inject.
+ econstructor; eauto. rewrite Ptrofs.add_zero_l; auto.
+Qed.
+
+End EVAL_INJECT.
diff --git a/x86/PrintOp.ml b/x86/PrintOp.ml
new file mode 100644
index 00000000..faa5bb5f
--- /dev/null
+++ b/x86/PrintOp.ml
@@ -0,0 +1,169 @@
+(* *********************************************************************)
+(* *)
+(* 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. *)
+(* *)
+(* *********************************************************************)
+
+(** Pretty-printing of operators, conditions, addressing modes *)
+
+open Printf
+open Camlcoq
+open Integers
+open Op
+
+let comparison_name = function
+ | Ceq -> "=="
+ | Cne -> "!="
+ | Clt -> "<"
+ | Cle -> "<="
+ | Cgt -> ">"
+ | Cge -> ">="
+
+let print_condition reg pp = function
+ | (Ccomp c, [r1;r2]) ->
+ fprintf pp "%a %ss %a" reg r1 (comparison_name c) reg r2
+ | (Ccompu c, [r1;r2]) ->
+ fprintf pp "%a %su %a" reg r1 (comparison_name c) reg r2
+ | (Ccompimm(c, n), [r1]) ->
+ fprintf pp "%a %ss %ld" reg r1 (comparison_name c) (camlint_of_coqint n)
+ | (Ccompuimm(c, n), [r1]) ->
+ fprintf pp "%a %su %lu" reg r1 (comparison_name c) (camlint_of_coqint n)
+ | (Ccompl c, [r1;r2]) ->
+ fprintf pp "%a %sls %a" reg r1 (comparison_name c) reg r2
+ | (Ccomplu c, [r1;r2]) ->
+ fprintf pp "%a %slu %a" reg r1 (comparison_name c) reg r2
+ | (Ccomplimm(c, n), [r1]) ->
+ fprintf pp "%a %sls %Ld" reg r1 (comparison_name c) (camlint64_of_coqint n)
+ | (Ccompluimm(c, n), [r1]) ->
+ fprintf pp "%a %slu %Lu" reg r1 (comparison_name c) (camlint64_of_coqint n)
+ | (Ccompf c, [r1;r2]) ->
+ fprintf pp "%a %sf %a" reg r1 (comparison_name c) reg r2
+ | (Cnotcompf c, [r1;r2]) ->
+ fprintf pp "%a not(%sf) %a" reg r1 (comparison_name c) reg r2
+ | (Ccompfs c, [r1;r2]) ->
+ fprintf pp "%a %sfs %a" reg r1 (comparison_name c) reg r2
+ | (Cnotcompfs c, [r1;r2]) ->
+ fprintf pp "%a not(%sfs) %a" reg r1 (comparison_name c) reg r2
+ | (Cmaskzero n, [r1]) ->
+ fprintf pp "%a & 0x%lx == 0" reg r1 (camlint_of_coqint n)
+ | (Cmasknotzero n, [r1]) ->
+ fprintf pp "%a & 0x%lx != 0" reg r1 (camlint_of_coqint n)
+ | _ ->
+ fprintf pp "<bad condition>"
+
+let print_addressing reg pp = function
+ | Aindexed n, [r1] ->
+ fprintf pp "%a + %s" reg r1 (Z.to_string n)
+ | Aindexed2 n, [r1; r2] ->
+ fprintf pp "%a + %a + %s" reg r1 reg r2 (Z.to_string n)
+ | Ascaled(sc,n), [r1] ->
+ fprintf pp "%a * %s + %s" reg r1 (Z.to_string sc) (Z.to_string n)
+ | Aindexed2scaled(sc, n), [r1; r2] ->
+ fprintf pp "%a + %a * %s + %s" reg r1 reg r2 (Z.to_string sc) (Z.to_string n)
+ | Aglobal(id, ofs), [] -> fprintf pp "%s + %s" (extern_atom id) (Z.to_string ofs)
+ | Abased(id, ofs), [r1] -> fprintf pp "%s + %s + %a" (extern_atom id) (Z.to_string ofs) reg r1
+ | Abasedscaled(sc,id, ofs), [r1] -> fprintf pp "%s + %s + %a * %ld" (extern_atom id) (Z.to_string ofs) reg r1 (camlint_of_coqint sc)
+ | Ainstack ofs, [] -> fprintf pp "stack(%s)" (Z.to_string ofs)
+ | _ -> fprintf pp "<bad addressing>"
+
+let print_operation reg pp = function
+ | Omove, [r1] -> reg pp r1
+ | Ointconst n, [] -> fprintf pp "%ld" (camlint_of_coqint n)
+ | Olongconst n, [] -> fprintf pp "%LdL" (camlint64_of_coqint n)
+ | Ofloatconst n, [] -> fprintf pp "%.15F" (camlfloat_of_coqfloat n)
+ | Osingleconst n, [] -> fprintf pp "%.15Ff" (camlfloat_of_coqfloat32 n)
+ | Oindirectsymbol id, [] -> fprintf pp "&%s" (extern_atom id)
+ | Ocast8signed, [r1] -> fprintf pp "int8signed(%a)" reg r1
+ | Ocast8unsigned, [r1] -> fprintf pp "int8unsigned(%a)" reg r1
+ | Ocast16signed, [r1] -> fprintf pp "int16signed(%a)" reg r1
+ | Ocast16unsigned, [r1] -> fprintf pp "int16unsigned(%a)" reg r1
+ | Oneg, [r1] -> fprintf pp "(- %a)" reg r1
+ | Osub, [r1;r2] -> fprintf pp "%a - %a" reg r1 reg r2
+ | Omul, [r1;r2] -> fprintf pp "%a * %a" reg r1 reg r2
+ | Omulimm n, [r1] -> fprintf pp "%a * %ld" reg r1 (camlint_of_coqint n)
+ | Omulhs, [r1;r2] -> fprintf pp "mulhs(%a,%a)" reg r1 reg r2
+ | Omulhu, [r1;r2] -> fprintf pp "mulhu(%a,%a)" reg r1 reg r2
+ | Odiv, [r1;r2] -> fprintf pp "%a /s %a" reg r1 reg r2
+ | Odivu, [r1;r2] -> fprintf pp "%a /u %a" reg r1 reg r2
+ | Omod, [r1;r2] -> fprintf pp "%a %%s %a" reg r1 reg r2
+ | Omodu, [r1;r2] -> fprintf pp "%a %%u %a" reg r1 reg r2
+ | Oand, [r1;r2] -> fprintf pp "%a & %a" reg r1 reg r2
+ | Oandimm n, [r1] -> fprintf pp "%a & %ld" reg r1 (camlint_of_coqint n)
+ | Oor, [r1;r2] -> fprintf pp "%a | %a" reg r1 reg r2
+ | Oorimm n, [r1] -> fprintf pp "%a | %ld" reg r1 (camlint_of_coqint n)
+ | Oxor, [r1;r2] -> fprintf pp "%a ^ %a" reg r1 reg r2
+ | Oxorimm n, [r1] -> fprintf pp "%a ^ %ld" reg r1 (camlint_of_coqint n)
+ | Onot, [r1] -> fprintf pp "not(%a)" reg r1
+ | Oshl, [r1;r2] -> fprintf pp "%a << %a" reg r1 reg r2
+ | Oshlimm n, [r1] -> fprintf pp "%a << %ld" reg r1 (camlint_of_coqint n)
+ | Oshr, [r1;r2] -> fprintf pp "%a >>s %a" reg r1 reg r2
+ | Oshrimm n, [r1] -> fprintf pp "%a >>s %ld" reg r1 (camlint_of_coqint n)
+ | Oshrximm n, [r1] -> fprintf pp "%a >>x %ld" reg r1 (camlint_of_coqint n)
+ | Oshru, [r1;r2] -> fprintf pp "%a >>u %a" reg r1 reg r2
+ | Oshruimm n, [r1] -> fprintf pp "%a >>u %ld" reg r1 (camlint_of_coqint n)
+ | Ororimm n, [r1] -> fprintf pp "%a ror %ld" reg r1 (camlint_of_coqint n)
+ | Oshldimm n, [r1;r2] -> fprintf pp "(%a, %a) << %ld" reg r1 reg r2 (camlint_of_coqint n)
+ | Olea addr, args -> print_addressing reg pp (addr, args); fprintf pp " (int)"
+ | Omakelong, [r1;r2] -> fprintf pp "makelong(%a,%a)" reg r1 reg r2
+ | Olowlong, [r1] -> fprintf pp "lowlong(%a)" reg r1
+ | Ohighlong, [r1] -> fprintf pp "highlong(%a)" reg r1
+ | Ocast32signed, [r1] -> fprintf pp "long32signed(%a)" reg r1
+ | Ocast32unsigned, [r1] -> fprintf pp "long32unsigned(%a)" reg r1
+ | Onegl, [r1] -> fprintf pp "(-l %a)" reg r1
+ | Osubl, [r1;r2] -> fprintf pp "%a -l %a" reg r1 reg r2
+ | Omull, [r1;r2] -> fprintf pp "%a *l %a" reg r1 reg r2
+ | Omullimm n, [r1] -> fprintf pp "%a *l %Ld" reg r1 (camlint64_of_coqint n)
+ | Omullhs, [r1;r2] -> fprintf pp "mullhs(%a,%a)" reg r1 reg r2
+ | Omullhu, [r1;r2] -> fprintf pp "mullhu(%a,%a)" reg r1 reg r2
+ | Odivl, [r1;r2] -> fprintf pp "%a /ls %a" reg r1 reg r2
+ | Odivlu, [r1;r2] -> fprintf pp "%a /lu %a" reg r1 reg r2
+ | Omodl, [r1;r2] -> fprintf pp "%a %%ls %a" reg r1 reg r2
+ | Omodlu, [r1;r2] -> fprintf pp "%a %%lu %a" reg r1 reg r2
+ | Oandl, [r1;r2] -> fprintf pp "%a &l %a" reg r1 reg r2
+ | Oandlimm n, [r1] -> fprintf pp "%a &l %Ld" reg r1 (camlint64_of_coqint n)
+ | Oorl, [r1;r2] -> fprintf pp "%a |l %a" reg r1 reg r2
+ | Oorlimm n, [r1] -> fprintf pp "%a |l %Ld" reg r1 (camlint64_of_coqint n)
+ | Oxorl, [r1;r2] -> fprintf pp "%a ^l %a" reg r1 reg r2
+ | Oxorlimm n, [r1] -> fprintf pp "%a ^l %Ld" reg r1 (camlint64_of_coqint n)
+ | Onotl, [r1] -> fprintf pp "notl(%a)" reg r1
+ | Oshll, [r1;r2] -> fprintf pp "%a <<l %a" reg r1 reg r2
+ | Oshllimm n, [r1] -> fprintf pp "%a <<l %ld" reg r1 (camlint_of_coqint n)
+ | Oshrl, [r1;r2] -> fprintf pp "%a >>ls %a" reg r1 reg r2
+ | Oshrlimm n, [r1] -> fprintf pp "%a >>ls %ld" reg r1 (camlint_of_coqint n)
+ | Oshrxlimm n, [r1] -> fprintf pp "%a >>lx %ld" reg r1 (camlint_of_coqint n)
+ | Oshrlu, [r1;r2] -> fprintf pp "%a >>lu %a" reg r1 reg r2
+ | Oshrluimm n, [r1] -> fprintf pp "%a >>lu %ld" reg r1 (camlint_of_coqint n)
+ | Ororlimm n, [r1] -> fprintf pp "%a rorl %ld" reg r1 (camlint_of_coqint n)
+ | Oleal addr, args -> print_addressing reg pp (addr, args); fprintf pp " (long)"
+ | Onegf, [r1] -> fprintf pp "negf(%a)" reg r1
+ | Oabsf, [r1] -> fprintf pp "absf(%a)" reg r1
+ | Oaddf, [r1;r2] -> fprintf pp "%a +f %a" reg r1 reg r2
+ | Osubf, [r1;r2] -> fprintf pp "%a -f %a" reg r1 reg r2
+ | Omulf, [r1;r2] -> fprintf pp "%a *f %a" reg r1 reg r2
+ | Odivf, [r1;r2] -> fprintf pp "%a /f %a" reg r1 reg r2
+ | Onegfs, [r1] -> fprintf pp "negfs(%a)" reg r1
+ | Oabsfs, [r1] -> fprintf pp "absfs(%a)" reg r1
+ | Oaddfs, [r1;r2] -> fprintf pp "%a +fs %a" reg r1 reg r2
+ | Osubfs, [r1;r2] -> fprintf pp "%a -fs %a" reg r1 reg r2
+ | Omulfs, [r1;r2] -> fprintf pp "%a *fs %a" reg r1 reg r2
+ | Odivfs, [r1;r2] -> fprintf pp "%a /fs %a" reg r1 reg r2
+ | Osingleoffloat, [r1] -> fprintf pp "singleoffloat(%a)" reg r1
+ | Ofloatofsingle, [r1] -> fprintf pp "floatofsingle(%a)" reg r1
+ | Ointoffloat, [r1] -> fprintf pp "intoffloat(%a)" reg r1
+ | Ofloatofint, [r1] -> fprintf pp "floatofint(%a)" reg r1
+ | Ointofsingle, [r1] -> fprintf pp "intofsingle(%a)" reg r1
+ | Osingleofint, [r1] -> fprintf pp "singleofint(%a)" reg r1
+ | Olongoffloat, [r1] -> fprintf pp "longoffloat(%a)" reg r1
+ | Ofloatoflong, [r1] -> fprintf pp "floatoflong(%a)" reg r1
+ | Olongofsingle, [r1] -> fprintf pp "longofsingle(%a)" reg r1
+ | Osingleoflong, [r1] -> fprintf pp "singleoflong(%a)" reg r1
+ | Ocmp c, args -> print_condition reg pp (c, args)
+ | _ -> fprintf pp "<bad operator>"
+
+
diff --git a/x86/SelectLong.vp b/x86/SelectLong.vp
new file mode 100644
index 00000000..b213e23f
--- /dev/null
+++ b/x86/SelectLong.vp
@@ -0,0 +1,347 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris *)
+(* *)
+(* 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 for 64-bit integer operations *)
+
+Require Import Coqlib.
+Require Import Compopts.
+Require Import AST Integers Floats.
+Require Import Op CminorSel.
+Require Import SelectOp SplitLong.
+
+Local Open Scope cminorsel_scope.
+Local Open Scope string_scope.
+
+Section SELECT.
+
+Context {hf: helper_functions}.
+
+Definition longconst (n: int64) : expr :=
+ if Archi.splitlong then SplitLong.longconst n else Eop (Olongconst n) Enil.
+
+Definition is_longconst (e: expr) :=
+ if Archi.splitlong then SplitLong.is_longconst e else
+ match e with
+ | Eop (Olongconst n) Enil => Some n
+ | _ => None
+ end.
+
+Definition intoflong (e: expr) :=
+ if Archi.splitlong then SplitLong.intoflong e else
+ match is_longconst e with
+ | Some n => Eop (Ointconst (Int.repr (Int64.unsigned n))) Enil
+ | None => Eop Olowlong (e ::: Enil)
+ end.
+
+Definition longofint (e: expr) :=
+ if Archi.splitlong then SplitLong.longofint e else
+ match is_intconst e with
+ | Some n => longconst (Int64.repr (Int.signed n))
+ | None => Eop Ocast32signed (e ::: Enil)
+ end.
+
+Definition longofintu (e: expr) :=
+ if Archi.splitlong then SplitLong.longofintu e else
+ match is_intconst e with
+ | Some n => longconst (Int64.repr (Int.unsigned n))
+ | None => Eop Ocast32unsigned (e ::: Enil)
+ end.
+
+Nondetfunction notl (e: expr) :=
+ if Archi.splitlong then SplitLong.notl e else
+ match e with
+ | Eop (Olongconst n) Enil => longconst (Int64.not n)
+ | Eop Onotl (t1:::Enil) => t1
+ | _ => Eop Onotl (e:::Enil)
+ end.
+
+Nondetfunction andlimm (n1: int64) (e2: expr) :=
+ if Int64.eq n1 Int64.zero then longconst Int64.zero else
+ if Int64.eq n1 Int64.mone then e2 else
+ match e2 with
+ | Eop (Olongconst n2) Enil =>
+ longconst (Int64.and n1 n2)
+ | Eop (Oandlimm n2) (t2:::Enil) =>
+ Eop (Oandlimm (Int64.and n1 n2)) (t2:::Enil)
+ | _ =>
+ Eop (Oandlimm n1) (e2:::Enil)
+ end.
+
+Nondetfunction andl (e1: expr) (e2: expr) :=
+ if Archi.splitlong then SplitLong.andl e1 e2 else
+ match e1, e2 with
+ | Eop (Olongconst n1) Enil, t2 => andlimm n1 t2
+ | t1, Eop (Olongconst n2) Enil => andlimm n2 t1
+ | _, _ => Eop Oandl (e1:::e2:::Enil)
+ end.
+
+Nondetfunction orlimm (n1: int64) (e2: expr) :=
+ if Int64.eq n1 Int64.zero then e2 else
+ if Int64.eq n1 Int64.mone then longconst Int64.mone else
+ match e2 with
+ | Eop (Olongconst n2) Enil => longconst (Int64.or n1 n2)
+ | Eop (Oorlimm n2) (t2:::Enil) => Eop (Oorlimm (Int64.or n1 n2)) (t2:::Enil)
+ | _ => Eop (Oorlimm n1) (e2:::Enil)
+ end.
+
+Nondetfunction orl (e1: expr) (e2: expr) :=
+ if Archi.splitlong then SplitLong.orl e1 e2 else
+ match e1, e2 with
+ | Eop (Olongconst n1) Enil, t2 => orlimm n1 t2
+ | t1, Eop (Olongconst n2) Enil => orlimm n2 t1
+ | Eop (Oshllimm n1) (t1:::Enil), Eop (Oshrluimm n2) (t2:::Enil) =>
+ if Int.eq (Int.add n1 n2) Int64.iwordsize' && same_expr_pure t1 t2
+ then Eop (Ororlimm n2) (t1:::Enil)
+ else Eop Oorl (e1:::e2:::Enil)
+ | Eop (Oshrluimm n2) (t2:::Enil), Eop (Oshllimm n1) (t1:::Enil) =>
+ if Int.eq (Int.add n1 n2) Int64.iwordsize' && same_expr_pure t1 t2
+ then Eop (Ororlimm n2) (t1:::Enil)
+ else Eop Oorl (e1:::e2:::Enil)
+ | _, _ =>
+ Eop Oorl (e1:::e2:::Enil)
+ end.
+
+Nondetfunction xorlimm (n1: int64) (e2: expr) :=
+ if Int64.eq n1 Int64.zero then e2 else
+ if Int64.eq n1 Int64.mone then notl e2 else
+ match e2 with
+ | Eop (Olongconst n2) Enil => longconst (Int64.xor n1 n2)
+ | Eop (Oxorlimm n2) (t2:::Enil) => Eop (Oxorlimm (Int64.xor n1 n2)) (t2:::Enil)
+ | Eop Onotl (t2:::Enil) => Eop (Oxorlimm (Int64.not n1)) (t2:::Enil)
+ | _ => Eop (Oxorlimm n1) (e2:::Enil)
+ end.
+
+Nondetfunction xorl (e1: expr) (e2: expr) :=
+ if Archi.splitlong then SplitLong.xorl e1 e2 else
+ match e1, e2 with
+ | Eop (Olongconst n1) Enil, t2 => xorlimm n1 t2
+ | t1, Eop (Olongconst n2) Enil => xorlimm n2 t1
+ | _, _ => Eop Oxorl (e1:::e2:::Enil)
+ end.
+
+Nondetfunction shllimm (e1: expr) (n: int) :=
+ if Archi.splitlong then SplitLong.shllimm e1 n else
+ if Int.eq n Int.zero then e1 else
+ if negb (Int.ltu n Int64.iwordsize') then
+ Eop Oshll (e1:::Eop (Ointconst n) Enil:::Enil)
+ else
+ match e1 with
+ | Eop (Olongconst n1) Enil =>
+ Eop (Olongconst(Int64.shl' n1 n)) Enil
+ | Eop (Oshllimm n1) (t1:::Enil) =>
+ if Int.ltu (Int.add n n1) Int64.iwordsize'
+ then Eop (Oshllimm (Int.add n n1)) (t1:::Enil)
+ else Eop (Oshllimm n) (e1:::Enil)
+ | Eop (Oleal (Aindexed n1)) (t1:::Enil) =>
+ if shift_is_scale n
+ then Eop (Oleal (Ascaled (Int64.unsigned (Int64.shl' Int64.one n))
+ (Int64.unsigned (Int64.shl' (Int64.repr n1) n)))) (t1:::Enil)
+ else Eop (Oshllimm n) (e1:::Enil)
+ | _ =>
+ if shift_is_scale n
+ then Eop (Oleal (Ascaled (Int64.unsigned (Int64.shl' Int64.one n)) 0)) (e1:::Enil)
+ else Eop (Oshllimm n) (e1:::Enil)
+ end.
+
+Nondetfunction shrluimm (e1: expr) (n: int) :=
+ if Archi.splitlong then SplitLong.shrluimm e1 n else
+ if Int.eq n Int.zero then e1 else
+ if negb (Int.ltu n Int64.iwordsize') then
+ Eop Oshrlu (e1:::Eop (Ointconst n) Enil:::Enil)
+ else
+ match e1 with
+ | Eop (Olongconst n1) Enil =>
+ Eop (Olongconst(Int64.shru' n1 n)) Enil
+ | Eop (Oshrluimm n1) (t1:::Enil) =>
+ if Int.ltu (Int.add n n1) Int64.iwordsize'
+ then Eop (Oshrluimm (Int.add n n1)) (t1:::Enil)
+ else Eop (Oshrluimm n) (e1:::Enil)
+ | _ =>
+ Eop (Oshrluimm n) (e1:::Enil)
+ end.
+
+Nondetfunction shrlimm (e1: expr) (n: int) :=
+ if Archi.splitlong then SplitLong.shrlimm e1 n else
+ if Int.eq n Int.zero then e1 else
+ if negb (Int.ltu n Int64.iwordsize') then
+ Eop Oshrl (e1:::Eop (Ointconst n) Enil:::Enil)
+ else
+ match e1 with
+ | Eop (Olongconst n1) Enil =>
+ Eop (Olongconst(Int64.shr' n1 n)) Enil
+ | Eop (Oshrlimm n1) (t1:::Enil) =>
+ if Int.ltu (Int.add n n1) Int64.iwordsize'
+ then Eop (Oshrlimm (Int.add n n1)) (t1:::Enil)
+ else Eop (Oshrlimm n) (e1:::Enil)
+ | _ =>
+ Eop (Oshrlimm n) (e1:::Enil)
+ end.
+
+Definition shll (e1: expr) (e2: expr) :=
+ if Archi.splitlong then SplitLong.shll e1 e2 else
+ match is_intconst e2 with
+ | Some n2 => shllimm e1 n2
+ | None => Eop Oshll (e1:::e2:::Enil)
+ end.
+
+Definition shrl (e1: expr) (e2: expr) :=
+ if Archi.splitlong then SplitLong.shrl e1 e2 else
+ match is_intconst e2 with
+ | Some n2 => shrlimm e1 n2
+ | None => Eop Oshrl (e1:::e2:::Enil)
+ end.
+
+Definition shrlu (e1: expr) (e2: expr) :=
+ if Archi.splitlong then SplitLong.shrlu e1 e2 else
+ match is_intconst e2 with
+ | Some n2 => shrluimm e1 n2
+ | _ => Eop Oshrlu (e1:::e2:::Enil)
+ end.
+
+Nondetfunction addlimm (n: int64) (e: expr) :=
+ if Int64.eq n Int64.zero then e else
+ match e with
+ | Eop (Olongconst m) Enil => longconst (Int64.add n m)
+ | Eop (Oleal addr) args => Eop (Oleal (offset_addressing_total addr (Int64.signed n))) args
+ | _ => Eop (Oleal (Aindexed (Int64.signed n))) (e ::: Enil)
+ end.
+
+Nondetfunction addl (e1: expr) (e2: expr) :=
+ if Archi.splitlong then SplitLong.addl e1 e2 else
+ match e1, e2 with
+ | Eop (Olongconst n1) Enil, t2 => addlimm n1 t2
+ | t1, Eop (Olongconst n2) Enil => addlimm n2 t1
+ | Eop (Oleal (Aindexed n1)) (t1:::Enil), Eop (Oleal (Aindexed n2)) (t2:::Enil) =>
+ Eop (Oleal (Aindexed2 (n1 + n2))) (t1:::t2:::Enil)
+ | Eop (Oleal (Aindexed n1)) (t1:::Enil), Eop (Oleal (Ascaled sc n2)) (t2:::Enil) =>
+ Eop (Oleal (Aindexed2scaled sc (n1 + n2))) (t1:::t2:::Enil)
+ | Eop (Oleal (Ascaled sc n1)) (t1:::Enil), Eop (Oleal (Aindexed n2)) (t2:::Enil) =>
+ Eop (Oleal (Aindexed2scaled sc (n1 + n2))) (t2:::t1:::Enil)
+ | Eop (Oleal (Ascaled sc n)) (t1:::Enil), t2 =>
+ Eop (Oleal (Aindexed2scaled sc n)) (t2:::t1:::Enil)
+ | t1, Eop (Oleal (Ascaled sc n)) (t2:::Enil) =>
+ Eop (Oleal (Aindexed2scaled sc n)) (t1:::t2:::Enil)
+ | Eop (Oleal (Aindexed n)) (t1:::Enil), t2 =>
+ Eop (Oleal (Aindexed2 n)) (t1:::t2:::Enil)
+ | t1, Eop (Oleal (Aindexed n)) (t2:::Enil) =>
+ Eop (Oleal (Aindexed2 n)) (t1:::t2:::Enil)
+ | _, _ =>
+ Eop (Oleal (Aindexed2 0)) (e1:::e2:::Enil)
+ end.
+
+Definition negl (e: expr) :=
+ if Archi.splitlong then SplitLong.negl e else
+ match is_longconst e with
+ | Some n => longconst (Int64.neg n)
+ | None => Eop Onegl (e ::: Enil)
+ end.
+
+Nondetfunction subl (e1: expr) (e2: expr) :=
+ if Archi.splitlong then SplitLong.subl e1 e2 else
+ match e1, e2 with
+ | t1, Eop (Olongconst n2) Enil => addlimm (Int64.neg n2) t1
+ | Eop (Oleal (Aindexed n1)) (t1:::Enil), Eop (Oleal (Aindexed n2)) (t2:::Enil) =>
+ addlimm (Int64.repr (n1 - n2)) (Eop Osubl (t1:::t2:::Enil))
+ | Eop (Oleal (Aindexed n1)) (t1:::Enil), t2 =>
+ addlimm (Int64.repr n1) (Eop Osubl (t1:::t2:::Enil))
+ | t1, Eop (Oleal (Aindexed n2)) (t2:::Enil) =>
+ addlimm (Int64.repr (- n2)) (Eop Osubl (t1:::t2:::Enil))
+ | _, _ =>
+ Eop Osubl (e1:::e2:::Enil)
+ end.
+
+Definition mullimm_base (n1: int64) (e2: expr) :=
+ match Int64.one_bits' n1 with
+ | i :: nil =>
+ shllimm e2 i
+ | i :: j :: nil =>
+ Elet e2 (addl (shllimm (Eletvar 0) i) (shllimm (Eletvar 0) j))
+ | _ =>
+ Eop (Omullimm n1) (e2:::Enil)
+ end.
+
+Nondetfunction mullimm (n1: int64) (e2: expr) :=
+ if Archi.splitlong then SplitLong.mullimm n1 e2
+ else if Int64.eq n1 Int64.zero then longconst Int64.zero
+ else if Int64.eq n1 Int64.one then e2
+ else match e2 with
+ | Eop (Olongconst n2) Enil => longconst (Int64.mul n1 n2)
+ | Eop (Oleal (Aindexed n2)) (t2:::Enil) => addlimm (Int64.mul n1 (Int64.repr n2)) (mullimm_base n1 t2)
+ | _ => mullimm_base n1 e2
+ end.
+
+Nondetfunction mull (e1: expr) (e2: expr) :=
+ if Archi.splitlong then SplitLong.mull e1 e2 else
+ match e1, e2 with
+ | Eop (Olongconst n1) Enil, t2 => mullimm n1 t2
+ | t1, Eop (Olongconst n2) Enil => mullimm n2 t1
+ | _, _ => Eop Omull (e1:::e2:::Enil)
+ end.
+
+Definition mullhu (e1: expr) (n2: int64) :=
+ if Archi.splitlong then SplitLong.mullhu e1 n2 else
+ Eop Omullhu (e1 ::: longconst n2 ::: Enil).
+
+Definition mullhs (e1: expr) (n2: int64) :=
+ if Archi.splitlong then SplitLong.mullhs e1 n2 else
+ Eop Omullhs (e1 ::: longconst n2 ::: Enil).
+
+Definition shrxlimm (e: expr) (n: int) :=
+ if Archi.splitlong then SplitLong.shrxlimm e n else
+ if Int.eq n Int.zero then e else Eop (Oshrxlimm n) (e ::: Enil).
+
+Definition divlu_base (e1: expr) (e2: expr) :=
+ if Archi.splitlong then SplitLong.divlu_base e1 e2 else Eop Odivlu (e1:::e2:::Enil).
+Definition modlu_base (e1: expr) (e2: expr) :=
+ if Archi.splitlong then SplitLong.modlu_base e1 e2 else Eop Omodlu (e1:::e2:::Enil).
+Definition divls_base (e1: expr) (e2: expr) :=
+ if Archi.splitlong then SplitLong.divls_base e1 e2 else Eop Odivl (e1:::e2:::Enil).
+Definition modls_base (e1: expr) (e2: expr) :=
+ if Archi.splitlong then SplitLong.modls_base e1 e2 else Eop Omodl (e1:::e2:::Enil).
+
+Definition cmplu (c: comparison) (e1 e2: expr) :=
+ if Archi.splitlong then SplitLong.cmplu c e1 e2 else
+ match is_longconst e1, is_longconst e2 with
+ | Some n1, Some n2 =>
+ Eop (Ointconst (if Int64.cmpu c n1 n2 then Int.one else Int.zero)) Enil
+ | Some n1, None => Eop (Ocmp (Ccompluimm (swap_comparison c) n1)) (e2:::Enil)
+ | None, Some n2 => Eop (Ocmp (Ccompluimm c n2)) (e1:::Enil)
+ | None, None => Eop (Ocmp (Ccomplu c)) (e1:::e2:::Enil)
+ end.
+
+Definition cmpl (c: comparison) (e1 e2: expr) :=
+ if Archi.splitlong then SplitLong.cmpl c e1 e2 else
+ match is_longconst e1, is_longconst e2 with
+ | Some n1, Some n2 =>
+ Eop (Ointconst (if Int64.cmp c n1 n2 then Int.one else Int.zero)) Enil
+ | Some n1, None => Eop (Ocmp (Ccomplimm (swap_comparison c) n1)) (e2:::Enil)
+ | None, Some n2 => Eop (Ocmp (Ccomplimm c n2)) (e1:::Enil)
+ | None, None => Eop (Ocmp (Ccompl c)) (e1:::e2:::Enil)
+ end.
+
+Definition longoffloat (e: expr) :=
+ if Archi.splitlong then SplitLong.longoffloat e else
+ Eop Olongoffloat (e:::Enil).
+
+Definition floatoflong (e: expr) :=
+ if Archi.splitlong then SplitLong.floatoflong e else
+ Eop Ofloatoflong (e:::Enil).
+
+Definition longofsingle (e: expr) :=
+ if Archi.splitlong then SplitLong.longofsingle e else
+ Eop Olongofsingle (e:::Enil).
+
+Definition singleoflong (e: expr) :=
+ if Archi.splitlong then SplitLong.singleoflong e else
+ Eop Osingleoflong (e:::Enil).
+
+End SELECT.
diff --git a/x86/SelectLongproof.v b/x86/SelectLongproof.v
new file mode 100644
index 00000000..f7d5df10
--- /dev/null
+++ b/x86/SelectLongproof.v
@@ -0,0 +1,555 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris *)
+(* *)
+(* 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 for 64-bit integer operations *)
+
+Require Import String Coqlib Maps Integers Floats Errors.
+Require Archi.
+Require Import AST Values Memory Globalenvs Events.
+Require Import Cminor Op CminorSel.
+Require Import SelectOp SelectOpproof SplitLong SplitLongproof.
+Require Import SelectLong.
+
+Open Local Scope cminorsel_scope.
+Open Local Scope string_scope.
+
+(** * Correctness of the instruction selection functions for 64-bit operators *)
+
+Section CMCONSTR.
+
+Variable prog: program.
+Variable hf: helper_functions.
+Hypothesis HELPERS: helper_functions_declared prog hf.
+Let ge := Genv.globalenv prog.
+Variable sp: val.
+Variable e: env.
+Variable m: mem.
+
+Definition unary_constructor_sound (cstr: expr -> expr) (sem: val -> val) : Prop :=
+ forall le a x,
+ eval_expr ge sp e m le a x ->
+ exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef (sem x) v.
+
+Definition binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> val) : Prop :=
+ forall le a x b y,
+ eval_expr ge sp e m le a x ->
+ eval_expr ge sp e m le b y ->
+ exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef (sem x y) v.
+
+Definition partial_unary_constructor_sound (cstr: expr -> expr) (sem: val -> option val) : Prop :=
+ forall le a x y,
+ eval_expr ge sp e m le a x ->
+ sem x = Some y ->
+ exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef y v.
+
+Definition partial_binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> option val) : Prop :=
+ forall le a x b y z,
+ eval_expr ge sp e m le a x ->
+ eval_expr ge sp e m le b y ->
+ sem x y = Some z ->
+ exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef z v.
+
+Theorem eval_longconst:
+ forall le n, eval_expr ge sp e m le (longconst n) (Vlong n).
+Proof.
+ unfold longconst; intros; destruct Archi.splitlong.
+ apply SplitLongproof.eval_longconst.
+ EvalOp.
+Qed.
+
+Lemma is_longconst_sound:
+ forall v a n le,
+ is_longconst a = Some n -> eval_expr ge sp e m le a v -> v = Vlong n.
+Proof with (try discriminate).
+ intros. unfold is_longconst in *. destruct Archi.splitlong.
+ eapply SplitLongproof.is_longconst_sound; eauto.
+ assert (a = Eop (Olongconst n) Enil).
+ { destruct a... destruct o... destruct e0... congruence. }
+ subst a. InvEval. auto.
+Qed.
+
+Theorem eval_intoflong: unary_constructor_sound intoflong Val.loword.
+Proof.
+ unfold intoflong; destruct Archi.splitlong. apply SplitLongproof.eval_intoflong.
+ red; intros. destruct (is_longconst a) as [n|] eqn:C.
+- TrivialExists. simpl. erewrite (is_longconst_sound x) by eauto. auto.
+- TrivialExists.
+Qed.
+
+Theorem eval_longofintu: unary_constructor_sound longofintu Val.longofintu.
+Proof.
+ unfold longofintu; destruct Archi.splitlong. apply SplitLongproof.eval_longofintu.
+ red; intros. destruct (is_intconst a) as [n|] eqn:C.
+- econstructor; split. apply eval_longconst.
+ exploit is_intconst_sound; eauto. intros; subst x. auto.
+- TrivialExists.
+Qed.
+
+Theorem eval_longofint: unary_constructor_sound longofint Val.longofint.
+Proof.
+ unfold longofint; destruct Archi.splitlong. apply SplitLongproof.eval_longofint.
+ red; intros. destruct (is_intconst a) as [n|] eqn:C.
+- econstructor; split. apply eval_longconst.
+ exploit is_intconst_sound; eauto. intros; subst x. auto.
+- TrivialExists.
+Qed.
+
+Theorem eval_notl: unary_constructor_sound notl Val.notl.
+Proof.
+ unfold notl; destruct Archi.splitlong. apply SplitLongproof.eval_notl.
+ red; intros. destruct (notl_match a).
+- InvEval. econstructor; split. apply eval_longconst. auto.
+- InvEval. subst. exists v1; split; auto. destruct v1; simpl; auto. rewrite Int64.not_involutive; auto.
+- TrivialExists.
+Qed.
+
+Theorem eval_andlimm: forall n, unary_constructor_sound (andlimm n) (fun v => Val.andl v (Vlong n)).
+Proof.
+ unfold andlimm; intros; red; intros.
+ predSpec Int64.eq Int64.eq_spec n Int64.zero.
+ exists (Vlong Int64.zero); split. apply eval_longconst.
+ subst. destruct x; simpl; auto. rewrite Int64.and_zero; auto.
+ predSpec Int64.eq Int64.eq_spec n Int64.mone.
+ exists x; split. assumption.
+ subst. destruct x; simpl; auto. rewrite Int64.and_mone; auto.
+ destruct (andlimm_match a); InvEval; subst.
+- econstructor; split. apply eval_longconst. simpl. rewrite Int64.and_commut; auto.
+- TrivialExists. simpl. rewrite Val.andl_assoc. rewrite Int64.and_commut; auto.
+- TrivialExists.
+Qed.
+
+Theorem eval_andl: binary_constructor_sound andl Val.andl.
+Proof.
+ unfold andl; destruct Archi.splitlong. apply SplitLongproof.eval_andl.
+ red; intros. destruct (andl_match a b).
+- InvEval. rewrite Val.andl_commut. apply eval_andlimm; auto.
+- InvEval. apply eval_andlimm; auto.
+- TrivialExists.
+Qed.
+
+Theorem eval_orlimm: forall n, unary_constructor_sound (orlimm n) (fun v => Val.orl v (Vlong n)).
+Proof.
+ unfold orlimm; intros; red; intros.
+ predSpec Int64.eq Int64.eq_spec n Int64.zero.
+ exists x; split; auto. subst. destruct x; simpl; auto. rewrite Int64.or_zero; auto.
+ predSpec Int64.eq Int64.eq_spec n Int64.mone.
+ econstructor; split. apply eval_longconst. subst. destruct x; simpl; auto. rewrite Int64.or_mone; auto.
+ destruct (orlimm_match a); InvEval; subst.
+- econstructor; split. apply eval_longconst. simpl. rewrite Int64.or_commut; auto.
+- TrivialExists. simpl. rewrite Val.orl_assoc. rewrite Int64.or_commut; auto.
+- TrivialExists.
+Qed.
+
+Theorem eval_orl: binary_constructor_sound orl Val.orl.
+Proof.
+ unfold orl; destruct Archi.splitlong. apply SplitLongproof.eval_orl.
+ red; intros.
+ assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop Oorl (a:::b:::Enil)) v /\ Val.lessdef (Val.orl x y) v) by TrivialExists.
+ assert (ROR: forall v n1 n2,
+ Int.add n1 n2 = Int64.iwordsize' ->
+ Val.lessdef (Val.orl (Val.shll v (Vint n1)) (Val.shrlu v (Vint n2)))
+ (Val.rorl v (Vint n2))).
+ { intros. destruct v; simpl; auto.
+ destruct (Int.ltu n1 Int64.iwordsize') eqn:N1; auto.
+ destruct (Int.ltu n2 Int64.iwordsize') eqn:N2; auto.
+ simpl. rewrite <- Int64.or_ror'; auto. }
+ destruct (orl_match a b).
+- InvEval. rewrite Val.orl_commut. apply eval_orlimm; auto.
+- InvEval. apply eval_orlimm; auto.
+- predSpec Int.eq Int.eq_spec (Int.add n1 n2) Int64.iwordsize'; auto.
+ destruct (same_expr_pure t1 t2) eqn:?; auto.
+ InvEval. exploit eval_same_expr; eauto. intros [EQ1 EQ2]; subst.
+ exists (Val.rorl v0 (Vint n2)); split. EvalOp. apply ROR; auto.
+- predSpec Int.eq Int.eq_spec (Int.add n1 n2) Int64.iwordsize'; auto.
+ destruct (same_expr_pure t1 t2) eqn:?; auto.
+ InvEval. exploit eval_same_expr; eauto. intros [EQ1 EQ2]; subst.
+ exists (Val.rorl v1 (Vint n2)); split. EvalOp. rewrite Val.orl_commut. apply ROR; auto.
+- apply DEFAULT.
+Qed.
+
+Theorem eval_xorlimm: forall n, unary_constructor_sound (xorlimm n) (fun v => Val.xorl v (Vlong n)).
+Proof.
+ unfold xorlimm; intros; red; intros.
+ predSpec Int64.eq Int64.eq_spec n Int64.zero.
+ exists x; split; auto. subst. destruct x; simpl; auto. rewrite Int64.xor_zero; auto.
+ predSpec Int64.eq Int64.eq_spec n Int64.mone.
+ replace (Val.xorl x (Vlong n)) with (Val.notl x). apply eval_notl; auto.
+ subst n. destruct x; simpl; auto.
+ destruct (xorlimm_match a); InvEval; subst.
+- econstructor; split. apply eval_longconst. simpl. rewrite Int64.xor_commut; auto.
+- TrivialExists. simpl. rewrite Val.xorl_assoc. rewrite Int64.xor_commut; auto.
+- TrivialExists. simpl. destruct v1; simpl; auto. unfold Int64.not.
+ rewrite Int64.xor_assoc. apply f_equal. apply f_equal. apply f_equal.
+ apply Int64.xor_commut.
+- TrivialExists.
+Qed.
+
+Theorem eval_xorl: binary_constructor_sound xorl Val.xorl.
+Proof.
+ unfold xorl; destruct Archi.splitlong. apply SplitLongproof.eval_xorl.
+ red; intros. destruct (xorl_match a b).
+- InvEval. rewrite Val.xorl_commut. apply eval_xorlimm; auto.
+- InvEval. apply eval_xorlimm; auto.
+- TrivialExists.
+Qed.
+
+Theorem eval_shllimm: forall n, unary_constructor_sound (fun e => shllimm e n) (fun v => Val.shll v (Vint n)).
+Proof.
+ intros; unfold shllimm. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shllimm; auto.
+ red; intros.
+ predSpec Int.eq Int.eq_spec n Int.zero.
+ exists x; split; auto. subst n; destruct x; simpl; auto.
+ destruct (Int.ltu Int.zero Int64.iwordsize'); auto.
+ change (Int64.shl' i Int.zero) with (Int64.shl i Int64.zero). rewrite Int64.shl_zero; auto.
+ destruct (Int.ltu n Int64.iwordsize') eqn:LT; simpl.
+ assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop (Oshllimm n) (a:::Enil)) v
+ /\ Val.lessdef (Val.shll x (Vint n)) v) by TrivialExists.
+ destruct (shllimm_match a); InvEval.
+- TrivialExists. simpl; rewrite LT; auto.
+- destruct (Int.ltu (Int.add n n1) Int64.iwordsize') eqn:LT'; auto.
+ subst. econstructor; split. EvalOp. simpl; eauto.
+ destruct v1; simpl; auto. rewrite LT'.
+ destruct (Int.ltu n1 Int64.iwordsize') eqn:LT1; auto.
+ simpl; rewrite LT. rewrite Int.add_commut, Int64.shl'_shl'; auto. rewrite Int.add_commut; auto.
+- destruct (shift_is_scale n); auto.
+ TrivialExists. simpl. destruct v1; simpl; auto.
+ rewrite LT. rewrite ! Int64.repr_unsigned. rewrite Int64.shl'_one_two_p.
+ rewrite ! Int64.shl'_mul_two_p. rewrite Int64.mul_add_distr_l. auto.
+- destruct (shift_is_scale n); auto.
+ TrivialExists. simpl. destruct x; simpl; auto.
+ rewrite LT. rewrite ! Int64.repr_unsigned. rewrite Int64.shl'_one_two_p.
+ rewrite ! Int64.shl'_mul_two_p. rewrite Int64.add_zero. auto.
+- TrivialExists. constructor; eauto. constructor. EvalOp. simpl; eauto. constructor. auto.
+Qed.
+
+Theorem eval_shrluimm: forall n, unary_constructor_sound (fun e => shrluimm e n) (fun v => Val.shrlu v (Vint n)).
+Proof.
+ intros; unfold shrluimm. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrluimm; auto.
+ red; intros.
+ predSpec Int.eq Int.eq_spec n Int.zero.
+ exists x; split; auto. subst n; destruct x; simpl; auto.
+ destruct (Int.ltu Int.zero Int64.iwordsize'); auto.
+ change (Int64.shru' i Int.zero) with (Int64.shru i Int64.zero). rewrite Int64.shru_zero; auto.
+ destruct (Int.ltu n Int64.iwordsize') eqn:LT; simpl.
+ assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop (Oshrluimm n) (a:::Enil)) v
+ /\ Val.lessdef (Val.shrlu x (Vint n)) v) by TrivialExists.
+ destruct (shrluimm_match a); InvEval.
+- TrivialExists. simpl; rewrite LT; auto.
+- destruct (Int.ltu (Int.add n n1) Int64.iwordsize') eqn:LT'; auto.
+ subst. econstructor; split. EvalOp. simpl; eauto.
+ destruct v1; simpl; auto. rewrite LT'.
+ destruct (Int.ltu n1 Int64.iwordsize') eqn:LT1; auto.
+ simpl; rewrite LT. rewrite Int.add_commut, Int64.shru'_shru'; auto. rewrite Int.add_commut; auto.
+- apply DEFAULT.
+- TrivialExists. constructor; eauto. constructor. EvalOp. simpl; eauto. constructor. auto.
+Qed.
+
+Theorem eval_shrlimm: forall n, unary_constructor_sound (fun e => shrlimm e n) (fun v => Val.shrl v (Vint n)).
+Proof.
+ intros; unfold shrlimm. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrlimm; auto.
+ red; intros.
+ predSpec Int.eq Int.eq_spec n Int.zero.
+ exists x; split; auto. subst n; destruct x; simpl; auto.
+ destruct (Int.ltu Int.zero Int64.iwordsize'); auto.
+ change (Int64.shr' i Int.zero) with (Int64.shr i Int64.zero). rewrite Int64.shr_zero; auto.
+ destruct (Int.ltu n Int64.iwordsize') eqn:LT; simpl.
+ assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop (Oshrlimm n) (a:::Enil)) v
+ /\ Val.lessdef (Val.shrl x (Vint n)) v) by TrivialExists.
+ destruct (shrlimm_match a); InvEval.
+- TrivialExists. simpl; rewrite LT; auto.
+- destruct (Int.ltu (Int.add n n1) Int64.iwordsize') eqn:LT'; auto.
+ subst. econstructor; split. EvalOp. simpl; eauto.
+ destruct v1; simpl; auto. rewrite LT'.
+ destruct (Int.ltu n1 Int64.iwordsize') eqn:LT1; auto.
+ simpl; rewrite LT. rewrite Int.add_commut, Int64.shr'_shr'; auto. rewrite Int.add_commut; auto.
+- apply DEFAULT.
+- TrivialExists. constructor; eauto. constructor. EvalOp. simpl; eauto. constructor. auto.
+Qed.
+
+Theorem eval_shll: binary_constructor_sound shll Val.shll.
+Proof.
+ unfold shll. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shll; auto.
+ red; intros. destruct (is_intconst b) as [n2|] eqn:C.
+- exploit is_intconst_sound; eauto. intros EQ; subst y. apply eval_shllimm; auto.
+- TrivialExists.
+Qed.
+
+Theorem eval_shrlu: binary_constructor_sound shrlu Val.shrlu.
+Proof.
+ unfold shrlu. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrlu; auto.
+ red; intros. destruct (is_intconst b) as [n2|] eqn:C.
+- exploit is_intconst_sound; eauto. intros EQ; subst y. apply eval_shrluimm; auto.
+- TrivialExists.
+Qed.
+
+Theorem eval_shrl: binary_constructor_sound shrl Val.shrl.
+Proof.
+ unfold shrl. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrl; auto.
+ red; intros. destruct (is_intconst b) as [n2|] eqn:C.
+- exploit is_intconst_sound; eauto. intros EQ; subst y. apply eval_shrlimm; auto.
+- TrivialExists.
+Qed.
+
+Theorem eval_negl: unary_constructor_sound negl Val.negl.
+Proof.
+ unfold negl. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_negl; auto.
+ red; intros. destruct (is_longconst a) as [n|] eqn:C.
+- exploit is_longconst_sound; eauto. intros EQ; subst x.
+ econstructor; split. apply eval_longconst. auto.
+- TrivialExists.
+Qed.
+
+Theorem eval_addlimm: forall n, unary_constructor_sound (addlimm n) (fun v => Val.addl v (Vlong n)).
+Proof.
+ unfold addlimm; intros; red; intros.
+ predSpec Int64.eq Int64.eq_spec n Int64.zero.
+ subst. exists x; split; auto.
+ destruct x; simpl; rewrite ?Int64.add_zero, ?Ptrofs.add_zero; auto.
+ destruct (addlimm_match a); InvEval.
+- econstructor; split. apply eval_longconst. rewrite Int64.add_commut; auto.
+- inv H. simpl in H6. TrivialExists. simpl.
+ erewrite eval_offset_addressing_total_64 by eauto. rewrite Int64.repr_signed; auto.
+- TrivialExists. simpl. rewrite Int64.repr_signed; auto.
+Qed.
+
+Theorem eval_addl: binary_constructor_sound addl Val.addl.
+Proof.
+ assert (A: forall x y, Int64.repr (x + y) = Int64.add (Int64.repr x) (Int64.repr y)).
+ { intros; apply Int64.eqm_samerepr; auto with ints. }
+ assert (B: forall id ofs n, Archi.ptr64 = true ->
+ Genv.symbol_address ge id (Ptrofs.add ofs (Ptrofs.repr n)) =
+ Val.addl (Genv.symbol_address ge id ofs) (Vlong (Int64.repr n))).
+ { intros. replace (Ptrofs.repr n) with (Ptrofs.of_int64 (Int64.repr n)) by auto with ptrofs.
+ apply Genv.shift_symbol_address_64; auto. }
+ unfold addl. destruct Archi.splitlong eqn:SL.
+ apply SplitLongproof.eval_addl. apply Archi.splitlong_ptr32; auto.
+ red; intros; destruct (addl_match a b); InvEval.
+- rewrite Val.addl_commut. apply eval_addlimm; auto.
+- apply eval_addlimm; auto.
+- subst. TrivialExists. simpl. rewrite A, Val.addl_permut_4. auto.
+- subst. TrivialExists. simpl. rewrite A, Val.addl_assoc. decEq; decEq. rewrite Val.addl_permut. auto.
+- subst. TrivialExists. simpl. rewrite A, Val.addl_permut_4. rewrite <- Val.addl_permut. rewrite <- Val.addl_assoc. auto.
+- subst. TrivialExists. simpl. rewrite Val.addl_commut; auto.
+- subst. TrivialExists.
+- subst. TrivialExists. simpl. rewrite ! Val.addl_assoc. rewrite (Val.addl_commut y). auto.
+- subst. TrivialExists. simpl. rewrite ! Val.addl_assoc. auto.
+- TrivialExists. simpl.
+ unfold Val.addl. destruct Archi.ptr64, x, y; auto.
+ + rewrite Int64.add_zero; auto.
+ + rewrite Ptrofs.add_assoc, Ptrofs.add_zero. auto.
+ + rewrite Ptrofs.add_assoc, Ptrofs.add_zero. auto.
+ + rewrite Int64.add_zero; auto.
+Qed.
+
+Theorem eval_subl: binary_constructor_sound subl Val.subl.
+Proof.
+ unfold subl. destruct Archi.splitlong eqn:SL.
+ apply SplitLongproof.eval_subl. apply Archi.splitlong_ptr32; auto.
+ red; intros; destruct (subl_match a b); InvEval.
+- rewrite Val.subl_addl_opp. apply eval_addlimm; auto.
+- subst. rewrite Val.subl_addl_l. rewrite Val.subl_addl_r.
+ rewrite Val.addl_assoc. simpl. rewrite Int64.add_commut. rewrite <- Int64.sub_add_opp.
+ replace (Int64.repr (n1 - n2)) with (Int64.sub (Int64.repr n1) (Int64.repr n2)).
+ apply eval_addlimm; EvalOp.
+ apply Int64.eqm_samerepr; auto with ints.
+- subst. rewrite Val.subl_addl_l. apply eval_addlimm; EvalOp.
+- subst. rewrite Val.subl_addl_r.
+ replace (Int64.repr (-n2)) with (Int64.neg (Int64.repr n2)).
+ apply eval_addlimm; EvalOp.
+ apply Int64.eqm_samerepr; auto with ints.
+- TrivialExists.
+Qed.
+
+Theorem eval_mullimm_base: forall n, unary_constructor_sound (mullimm_base n) (fun v => Val.mull v (Vlong n)).
+Proof.
+ intros; unfold mullimm_base. red; intros.
+ generalize (Int64.one_bits'_decomp n); intros D.
+ destruct (Int64.one_bits' n) as [ | i [ | j [ | ? ? ]]] eqn:B.
+- TrivialExists.
+- replace (Val.mull x (Vlong n)) with (Val.shll x (Vint i)).
+ apply eval_shllimm; auto.
+ simpl in D. rewrite D, Int64.add_zero. destruct x; simpl; auto.
+ rewrite (Int64.one_bits'_range n) by (rewrite B; auto with coqlib).
+ rewrite Int64.shl'_mul; auto.
+- set (le' := x :: le).
+ assert (A0: eval_expr ge sp e m le' (Eletvar O) x) by (constructor; reflexivity).
+ exploit (eval_shllimm i). eexact A0. intros (v1 & A1 & B1).
+ exploit (eval_shllimm j). eexact A0. intros (v2 & A2 & B2).
+ exploit (eval_addl). eexact A1. eexact A2. intros (v3 & A3 & B3).
+ exists v3; split. econstructor; eauto.
+ rewrite D. simpl. rewrite Int64.add_zero. destruct x; auto.
+ simpl in *.
+ rewrite (Int64.one_bits'_range n) in B1 by (rewrite B; auto with coqlib).
+ rewrite (Int64.one_bits'_range n) in B2 by (rewrite B; auto with coqlib).
+ inv B1; inv B2. simpl in B3; inv B3.
+ rewrite Int64.mul_add_distr_r. rewrite <- ! Int64.shl'_mul. auto.
+- TrivialExists.
+Qed.
+
+Theorem eval_mullimm: forall n, unary_constructor_sound (mullimm n) (fun v => Val.mull v (Vlong n)).
+Proof.
+ unfold mullimm. intros; red; intros.
+ destruct Archi.splitlong eqn:SL.
+ eapply SplitLongproof.eval_mullimm; eauto.
+ predSpec Int64.eq Int64.eq_spec n Int64.zero.
+ exists (Vlong Int64.zero); split. apply eval_longconst.
+ destruct x; simpl; auto. subst n; rewrite Int64.mul_zero; auto.
+ predSpec Int64.eq Int64.eq_spec n Int64.one.
+ exists x; split; auto.
+ destruct x; simpl; auto. subst n; rewrite Int64.mul_one; auto.
+ destruct (mullimm_match a); InvEval.
+- econstructor; split. apply eval_longconst. rewrite Int64.mul_commut; auto.
+- exploit (eval_mullimm_base n); eauto. intros (v2 & A2 & B2).
+ exploit (eval_addlimm (Int64.mul n (Int64.repr n2))). eexact A2. intros (v3 & A3 & B3).
+ exists v3; split; auto.
+ destruct v1; simpl; auto.
+ simpl in B2; inv B2. simpl in B3; inv B3. rewrite Int64.mul_add_distr_l.
+ rewrite (Int64.mul_commut n). auto.
+- apply eval_mullimm_base; auto.
+Qed.
+
+Theorem eval_mull: binary_constructor_sound mull Val.mull.
+Proof.
+ unfold mull. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_mull; auto.
+ red; intros; destruct (mull_match a b); InvEval.
+- rewrite Val.mull_commut. apply eval_mullimm; auto.
+- apply eval_mullimm; auto.
+- TrivialExists.
+Qed.
+
+Theorem eval_mullhu:
+ forall n, unary_constructor_sound (fun a => mullhu a n) (fun v => Val.mullhu v (Vlong n)).
+Proof.
+ unfold mullhu; intros. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_mullhu; auto.
+ red; intros. TrivialExists. constructor. eauto. constructor. apply eval_longconst. constructor. auto.
+Qed.
+
+Theorem eval_mullhs:
+ forall n, unary_constructor_sound (fun a => mullhs a n) (fun v => Val.mullhs v (Vlong n)).
+Proof.
+ unfold mullhs; intros. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_mullhs; auto.
+ red; intros. TrivialExists. constructor. eauto. constructor. apply eval_longconst. constructor. auto.
+Qed.
+
+Theorem eval_shrxlimm:
+ forall le a n x z,
+ eval_expr ge sp e m le a x ->
+ Val.shrxl x (Vint n) = Some z ->
+ exists v, eval_expr ge sp e m le (shrxlimm a n) v /\ Val.lessdef z v.
+Proof.
+ unfold shrxlimm; intros. destruct Archi.splitlong eqn:SL.
++ eapply SplitLongproof.eval_shrxlimm; eauto using Archi.splitlong_ptr32.
++ predSpec Int.eq Int.eq_spec n Int.zero.
+- subst n. destruct x; simpl in H0; inv H0. econstructor; split; eauto.
+ change (Int.ltu Int.zero (Int.repr 63)) with true. simpl. rewrite Int64.shrx'_zero; auto.
+- TrivialExists.
+Qed.
+
+Theorem eval_divls_base: partial_binary_constructor_sound divls_base Val.divls.
+Proof.
+ unfold divls_base; red; intros. destruct Archi.splitlong eqn:SL.
+ eapply SplitLongproof.eval_divls_base; eauto.
+ TrivialExists.
+Qed.
+
+Theorem eval_modls_base: partial_binary_constructor_sound modls_base Val.modls.
+Proof.
+ unfold modls_base; red; intros. destruct Archi.splitlong eqn:SL.
+ eapply SplitLongproof.eval_modls_base; eauto.
+ TrivialExists.
+Qed.
+
+Theorem eval_divlu_base: partial_binary_constructor_sound divlu_base Val.divlu.
+Proof.
+ unfold divlu_base; red; intros. destruct Archi.splitlong eqn:SL.
+ eapply SplitLongproof.eval_divlu_base; eauto.
+ TrivialExists.
+Qed.
+
+Theorem eval_modlu_base: partial_binary_constructor_sound modlu_base Val.modlu.
+Proof.
+ unfold modlu_base; red; intros. destruct Archi.splitlong eqn:SL.
+ eapply SplitLongproof.eval_modlu_base; eauto.
+ TrivialExists.
+Qed.
+
+Theorem eval_cmplu:
+ forall c le a x b y v,
+ eval_expr ge sp e m le a x ->
+ eval_expr ge sp e m le b y ->
+ Val.cmplu (Mem.valid_pointer m) c x y = Some v ->
+ eval_expr ge sp e m le (cmplu c a b) v.
+Proof.
+ unfold cmplu; intros. destruct Archi.splitlong eqn:SL.
+ eapply SplitLongproof.eval_cmplu; eauto using Archi.splitlong_ptr32.
+ unfold Val.cmplu in H1.
+ destruct (Val.cmplu_bool (Mem.valid_pointer m) c x y) as [vb|] eqn:C; simpl in H1; inv H1.
+ destruct (is_longconst a) as [n1|] eqn:LC1; destruct (is_longconst b) as [n2|] eqn:LC2;
+ try (assert (x = Vlong n1) by (eapply is_longconst_sound; eauto));
+ try (assert (y = Vlong n2) by (eapply is_longconst_sound; eauto));
+ subst.
+- simpl in C; inv C. EvalOp. destruct (Int64.cmpu c n1 n2); reflexivity.
+- EvalOp. simpl. rewrite Val.swap_cmplu_bool. rewrite C; auto.
+- EvalOp. simpl; rewrite C; auto.
+- EvalOp. simpl; rewrite C; auto.
+Qed.
+
+Theorem eval_cmpl:
+ forall c le a x b y v,
+ eval_expr ge sp e m le a x ->
+ eval_expr ge sp e m le b y ->
+ Val.cmpl c x y = Some v ->
+ eval_expr ge sp e m le (cmpl c a b) v.
+Proof.
+ unfold cmpl; intros. destruct Archi.splitlong eqn:SL.
+ eapply SplitLongproof.eval_cmpl; eauto.
+ unfold Val.cmpl in H1.
+ destruct (Val.cmpl_bool c x y) as [vb|] eqn:C; simpl in H1; inv H1.
+ destruct (is_longconst a) as [n1|] eqn:LC1; destruct (is_longconst b) as [n2|] eqn:LC2;
+ try (assert (x = Vlong n1) by (eapply is_longconst_sound; eauto));
+ try (assert (y = Vlong n2) by (eapply is_longconst_sound; eauto));
+ subst.
+- simpl in C; inv C. EvalOp. destruct (Int64.cmp c n1 n2); reflexivity.
+- EvalOp. simpl. rewrite Val.swap_cmpl_bool. rewrite C; auto.
+- EvalOp. simpl; rewrite C; auto.
+- EvalOp. simpl; rewrite C; auto.
+Qed.
+
+Theorem eval_longoffloat: partial_unary_constructor_sound longoffloat Val.longoffloat.
+Proof.
+ unfold longoffloat; red; intros. destruct Archi.splitlong eqn:SL.
+ eapply SplitLongproof.eval_longoffloat; eauto.
+ TrivialExists.
+Qed.
+
+Theorem eval_floatoflong: partial_unary_constructor_sound floatoflong Val.floatoflong.
+Proof.
+ unfold floatoflong; red; intros. destruct Archi.splitlong eqn:SL.
+ eapply SplitLongproof.eval_floatoflong; eauto.
+ TrivialExists.
+Qed.
+
+Theorem eval_longofsingle: partial_unary_constructor_sound longofsingle Val.longofsingle.
+Proof.
+ unfold longofsingle; red; intros. destruct Archi.splitlong eqn:SL.
+ eapply SplitLongproof.eval_longofsingle; eauto.
+ TrivialExists.
+Qed.
+
+Theorem eval_singleoflong: partial_unary_constructor_sound singleoflong Val.singleoflong.
+Proof.
+ unfold singleoflong; red; intros. destruct Archi.splitlong eqn:SL.
+ eapply SplitLongproof.eval_singleoflong; eauto.
+ TrivialExists.
+Qed.
+
+End CMCONSTR.
diff --git a/x86/SelectOp.vp b/x86/SelectOp.vp
new file mode 100644
index 00000000..db546d99
--- /dev/null
+++ b/x86/SelectOp.vp
@@ -0,0 +1,530 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris *)
+(* *)
+(* 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 for operators *)
+
+(** 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.
+
+ This file 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.
+
+ On top of the "smart constructor" functions defined below,
+ module [Selection] implements the actual instruction selection pass.
+*)
+
+Require Import Coqlib.
+Require Import Compopts.
+Require Import AST Integers Floats.
+Require Import Op CminorSel.
+
+Open Local Scope cminorsel_scope.
+
+(** ** Constants **)
+
+(** External oracle to determine whether a symbol should be addressed
+ through [Oindirectsymbol] or can be addressed via [Oleal Aglobal].
+ This is to accommodate MacOS X's limitations on references to data
+ symbols imported from shared libraries. It can also help with PIC
+ code under ELF. *)
+
+Parameter symbol_is_external: ident -> bool.
+
+Definition Olea_ptr (a: addressing) := if Archi.ptr64 then Oleal a else Olea a.
+
+Definition addrsymbol (id: ident) (ofs: ptrofs) :=
+ if symbol_is_external id then
+ if Ptrofs.eq ofs Ptrofs.zero
+ then Eop (Oindirectsymbol id) Enil
+ else Eop (Olea_ptr (Aindexed (Ptrofs.unsigned ofs))) (Eop (Oindirectsymbol id) Enil ::: Enil)
+ else
+ Eop (Olea_ptr (Aglobal id ofs)) Enil.
+
+Definition addrstack (ofs: ptrofs) :=
+ Eop (Olea_ptr (Ainstack ofs)) Enil.
+
+(** ** Integer logical negation *)
+
+Nondetfunction notint (e: expr) :=
+ match e with
+ | Eop (Ointconst n) Enil => Eop (Ointconst (Int.not n)) Enil
+ | Eop (Oxorimm n) (e1 ::: Enil) => Eop (Oxorimm (Int.not n)) (e1 ::: Enil)
+ | _ => Eop Onot (e ::: Enil)
+ end.
+
+(** ** Integer addition and pointer addition *)
+
+Nondetfunction 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 (Olea addr) args => Eop (Olea (offset_addressing_total addr (Int.signed n))) args
+ | _ => Eop (Olea (Aindexed (Int.signed n))) (e ::: Enil)
+ end.
+
+Nondetfunction add (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | Eop (Ointconst n1) Enil, t2 => addimm n1 t2
+ | t1, Eop (Ointconst n2) Enil => addimm n2 t1
+ | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) =>
+ Eop (Olea (Aindexed2 (n1 + n2))) (t1:::t2:::Enil)
+ | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Ascaled sc n2)) (t2:::Enil) =>
+ Eop (Olea (Aindexed2scaled sc (n1 + n2))) (t1:::t2:::Enil)
+ | Eop (Olea (Ascaled sc n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) =>
+ Eop (Olea (Aindexed2scaled sc (n1 + n2))) (t2:::t1:::Enil)
+ | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aglobal id ofs)) Enil =>
+ Eop (Olea (Abased id (Ptrofs.add ofs (Ptrofs.repr n1)))) (t1:::Enil)
+ | Eop (Olea (Aglobal id ofs)) Enil, Eop (Olea (Aindexed n2)) (t2:::Enil) =>
+ Eop (Olea (Abased id (Ptrofs.add ofs (Ptrofs.repr n2)))) (t2:::Enil)
+ | Eop (Olea (Ascaled sc n1)) (t1:::Enil), Eop (Olea (Aglobal id ofs)) Enil =>
+ Eop (Olea (Abasedscaled sc id (Ptrofs.add ofs (Ptrofs.repr n1)))) (t1:::Enil)
+ | Eop (Olea (Aglobal id ofs)) Enil, Eop (Olea (Ascaled sc n2)) (t2:::Enil) =>
+ Eop (Olea (Abasedscaled sc id (Ptrofs.add ofs (Ptrofs.repr n2)))) (t2:::Enil)
+ | Eop (Olea (Ascaled sc n)) (t1:::Enil), t2 =>
+ Eop (Olea (Aindexed2scaled sc n)) (t2:::t1:::Enil)
+ | t1, Eop (Olea (Ascaled sc n)) (t2:::Enil) =>
+ Eop (Olea (Aindexed2scaled sc n)) (t1:::t2:::Enil)
+ | Eop (Olea (Aindexed n)) (t1:::Enil), t2 =>
+ Eop (Olea (Aindexed2 n)) (t1:::t2:::Enil)
+ | t1, Eop (Olea (Aindexed n)) (t2:::Enil) =>
+ Eop (Olea (Aindexed2 n)) (t1:::t2:::Enil)
+ | _, _ =>
+ Eop (Olea (Aindexed2 0)) (e1:::e2:::Enil)
+ end.
+
+(** ** Opposite *)
+
+Nondetfunction negint (e: expr) :=
+ match e with
+ | Eop (Ointconst n) Enil => Eop (Ointconst (Int.neg n)) Enil
+ | _ => Eop Oneg (e ::: Enil)
+ end.
+
+(** ** Integer and pointer subtraction *)
+
+Nondetfunction sub (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | t1, Eop (Ointconst n2) Enil => addimm (Int.neg n2) t1
+ | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) =>
+ addimm (Int.repr (n1 - n2)) (Eop Osub (t1:::t2:::Enil))
+ | Eop (Olea (Aindexed n1)) (t1:::Enil), t2 =>
+ addimm (Int.repr n1) (Eop Osub (t1:::t2:::Enil))
+ | t1, Eop (Olea (Aindexed n2)) (t2:::Enil) =>
+ addimm (Int.repr (-n2)) (Eop Osub (t1:::t2:::Enil))
+ | _, _ =>
+ Eop Osub (e1:::e2:::Enil)
+ end.
+
+(** ** Immediate shifts *)
+
+Definition shift_is_scale (n: int) : bool :=
+ Int.eq n (Int.repr 1) || Int.eq n (Int.repr 2) || Int.eq n (Int.repr 3).
+
+Nondetfunction shlimm (e1: expr) (n: int) :=
+ if Int.eq n Int.zero then e1 else
+ if negb (Int.ltu n Int.iwordsize) then
+ Eop Oshl (e1:::Eop (Ointconst n) Enil:::Enil)
+ else
+ match e1 with
+ | Eop (Ointconst n1) Enil =>
+ Eop (Ointconst(Int.shl n1 n)) Enil
+ | Eop (Oshlimm n1) (t1:::Enil) =>
+ if Int.ltu (Int.add n n1) Int.iwordsize
+ then Eop (Oshlimm (Int.add n n1)) (t1:::Enil)
+ else Eop (Oshlimm n) (e1:::Enil)
+ | Eop (Olea (Aindexed n1)) (t1:::Enil) =>
+ if shift_is_scale n
+ then Eop (Olea (Ascaled (Int.unsigned (Int.shl Int.one n))
+ (Int.unsigned (Int.shl (Int.repr n1) n)))) (t1:::Enil)
+ else Eop (Oshlimm n) (e1:::Enil)
+ | _ =>
+ if shift_is_scale n
+ then Eop (Olea (Ascaled (Int.unsigned (Int.shl Int.one n)) 0)) (e1:::Enil)
+ else Eop (Oshlimm n) (e1:::Enil)
+ end.
+
+Nondetfunction shruimm (e1: expr) (n: int) :=
+ if Int.eq n Int.zero then e1 else
+ if negb (Int.ltu n Int.iwordsize) then
+ Eop Oshru (e1:::Eop (Ointconst n) Enil:::Enil)
+ else
+ match e1 with
+ | Eop (Ointconst n1) Enil =>
+ Eop (Ointconst(Int.shru n1 n)) Enil
+ | Eop (Oshruimm n1) (t1:::Enil) =>
+ if Int.ltu (Int.add n n1) Int.iwordsize
+ then Eop (Oshruimm (Int.add n n1)) (t1:::Enil)
+ else Eop (Oshruimm n) (e1:::Enil)
+ | _ =>
+ Eop (Oshruimm n) (e1:::Enil)
+ end.
+
+Nondetfunction shrimm (e1: expr) (n: int) :=
+ if Int.eq n Int.zero then e1 else
+ if negb (Int.ltu n Int.iwordsize) then
+ Eop Oshr (e1:::Eop (Ointconst n) Enil:::Enil)
+ else
+ match e1 with
+ | Eop (Ointconst n1) Enil =>
+ Eop (Ointconst(Int.shr n1 n)) Enil
+ | Eop (Oshrimm n1) (t1:::Enil) =>
+ if Int.ltu (Int.add n n1) Int.iwordsize
+ then Eop (Oshrimm (Int.add n n1)) (t1:::Enil)
+ else Eop (Oshrimm n) (e1:::Enil)
+ | _ =>
+ Eop (Oshrimm n) (e1:::Enil)
+ end.
+
+(** ** 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 (add (shlimm (Eletvar 0) i) (shlimm (Eletvar 0) j))
+ | _ =>
+ Eop (Omulimm n1) (e2:::Enil)
+ end.
+
+Nondetfunction mulimm (n1: int) (e2: expr) :=
+ if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil
+ else if Int.eq n1 Int.one then e2
+ else match e2 with
+ | Eop (Ointconst n2) Enil => Eop (Ointconst(Int.mul n1 n2)) Enil
+ | Eop (Olea (Aindexed n2)) (t2:::Enil) => addimm (Int.mul n1 (Int.repr n2)) (mulimm_base n1 t2)
+ | _ => mulimm_base n1 e2
+ end.
+
+Nondetfunction 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.
+
+(** ** Bitwise and, or, xor *)
+
+Nondetfunction andimm (n1: int) (e2: expr) :=
+ if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil
+ else if Int.eq n1 Int.mone then e2
+ else match e2 with
+ | Eop (Ointconst n2) Enil =>
+ Eop (Ointconst (Int.and n1 n2)) Enil
+ | Eop (Oandimm n2) (t2:::Enil) =>
+ Eop (Oandimm (Int.and n1 n2)) (t2:::Enil)
+ | Eop Ocast8unsigned (t2:::Enil) =>
+ Eop (Oandimm (Int.and n1 (Int.repr 255))) (t2:::Enil)
+ | Eop Ocast16unsigned (t2:::Enil) =>
+ Eop (Oandimm (Int.and n1 (Int.repr 65535))) (t2:::Enil)
+ | _ =>
+ Eop (Oandimm n1) (e2:::Enil)
+ end.
+
+Nondetfunction and (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | Eop (Ointconst n1) Enil, t2 => andimm n1 t2
+ | t1, Eop (Ointconst n2) Enil => andimm n2 t1
+ | _, _ => Eop Oand (e1:::e2:::Enil)
+ end.
+
+Nondetfunction orimm (n1: int) (e2: expr) :=
+ if Int.eq n1 Int.zero then e2
+ else if Int.eq n1 Int.mone then Eop (Ointconst Int.mone) Enil
+ else match e2 with
+ | Eop (Ointconst n2) Enil =>
+ Eop (Ointconst (Int.or n1 n2)) Enil
+ | Eop (Oorimm n2) (t2:::Enil) =>
+ Eop (Oorimm (Int.or n1 n2)) (t2:::Enil)
+ | _ =>
+ Eop (Oorimm n1) (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.
+
+Nondetfunction or (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | Eop (Ointconst n1) Enil, t2 => orimm n1 t2
+ | t1, Eop (Ointconst n2) Enil => orimm n2 t1
+ | Eop (Oshlimm n1) (t1:::Enil), Eop (Oshruimm n2) (t2:::Enil) =>
+ if Int.eq (Int.add n1 n2) Int.iwordsize then
+ if same_expr_pure t1 t2
+ then Eop (Ororimm n2) (t1:::Enil)
+ else Eop (Oshldimm n1) (t1:::t2:::Enil)
+ else Eop Oor (e1:::e2:::Enil)
+ | Eop (Oshruimm n2) (t2:::Enil), Eop (Oshlimm n1) (t1:::Enil) =>
+ if Int.eq (Int.add n1 n2) Int.iwordsize then
+ if same_expr_pure t1 t2
+ then Eop (Ororimm n2) (t1:::Enil)
+ else Eop (Oshldimm n1) (t1:::t2:::Enil)
+ else Eop Oor (e1:::e2:::Enil)
+ | _, _ =>
+ Eop Oor (e1:::e2:::Enil)
+ end.
+
+Nondetfunction xorimm (n1: int) (e2: expr) :=
+ if Int.eq n1 Int.zero then e2
+ else match e2 with
+ | Eop (Ointconst n2) Enil =>
+ Eop (Ointconst (Int.xor n1 n2)) Enil
+ | Eop (Oxorimm n2) (t2:::Enil) =>
+ Eop (Oxorimm (Int.xor n1 n2)) (t2:::Enil)
+ | Eop Onot (t2:::Enil) =>
+ Eop (Oxorimm (Int.not n1)) (t2:::Enil)
+ | _ =>
+ Eop (Oxorimm n1) (e2:::Enil)
+ end.
+
+Nondetfunction xor (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | Eop (Ointconst n1) Enil, t2 => xorimm n1 t2
+ | t1, Eop (Ointconst n2) Enil => xorimm n2 t1
+ | _, _ => Eop Oxor (e1:::e2:::Enil)
+ end.
+
+(** ** Integer division and modulus *)
+
+Definition divu_base (e1: expr) (e2: expr) := Eop Odivu (e1:::e2:::Enil).
+Definition modu_base (e1: expr) (e2: expr) := Eop Omodu (e1:::e2:::Enil).
+Definition divs_base (e1: expr) (e2: expr) := Eop Odiv (e1:::e2:::Enil).
+Definition mods_base (e1: expr) (e2: expr) := Eop Omod (e1:::e2:::Enil).
+
+Definition shrximm (e1: expr) (n2: int) :=
+ if Int.eq n2 Int.zero then e1 else Eop (Oshrximm n2) (e1:::Enil).
+
+(** ** General shifts *)
+
+Nondetfunction shl (e1: expr) (e2: expr) :=
+ match e2 with
+ | Eop (Ointconst n2) Enil => shlimm e1 n2
+ | _ => Eop Oshl (e1:::e2:::Enil)
+ end.
+
+Nondetfunction shr (e1: expr) (e2: expr) :=
+ match e2 with
+ | Eop (Ointconst n2) Enil => shrimm e1 n2
+ | _ => Eop Oshr (e1:::e2:::Enil)
+ end.
+
+Nondetfunction shru (e1: expr) (e2: expr) :=
+ match e2 with
+ | Eop (Ointconst n2) Enil => shruimm e1 n2
+ | _ => Eop Oshru (e1:::e2:::Enil)
+ end.
+
+(** ** Floating-point arithmetic *)
+
+Definition negf (e: expr) := Eop Onegf (e ::: Enil).
+Definition absf (e: expr) := Eop Oabsf (e ::: Enil).
+Definition addf (e1 e2: expr) := Eop Oaddf (e1 ::: e2 ::: Enil).
+Definition subf (e1 e2: expr) := Eop Osubf (e1 ::: e2 ::: Enil).
+Definition mulf (e1 e2: expr) := Eop Omulf (e1 ::: e2 ::: Enil).
+
+Definition negfs (e: expr) := Eop Onegfs (e ::: Enil).
+Definition absfs (e: expr) := Eop Oabsfs (e ::: Enil).
+Definition addfs (e1 e2: expr) := Eop Oaddfs (e1 ::: e2 ::: Enil).
+Definition subfs (e1 e2: expr) := Eop Osubfs (e1 ::: e2 ::: Enil).
+Definition mulfs (e1 e2: expr) := Eop Omulfs (e1 ::: e2 ::: Enil).
+
+(** ** Comparisons *)
+
+Nondetfunction compimm (default: comparison -> int -> condition)
+ (sem: comparison -> int -> int -> bool)
+ (c: comparison) (e1: expr) (n2: int) :=
+ match c, e1 with
+ | c, Eop (Ointconst n1) Enil =>
+ Eop (Ointconst (if sem c n1 n2 then Int.one else Int.zero)) Enil
+ | Ceq, Eop (Ocmp c) el =>
+ if Int.eq_dec n2 Int.zero then
+ Eop (Ocmp (negate_condition c)) el
+ else if Int.eq_dec n2 Int.one then
+ Eop (Ocmp c) el
+ else
+ Eop (Ointconst Int.zero) Enil
+ | Cne, Eop (Ocmp c) el =>
+ if Int.eq_dec n2 Int.zero then
+ Eop (Ocmp c) el
+ else if Int.eq_dec n2 Int.one then
+ Eop (Ocmp (negate_condition c)) el
+ else
+ Eop (Ointconst Int.one) Enil
+ | Ceq, Eop (Oandimm n1) (t1 ::: Enil) =>
+ if Int.eq_dec n2 Int.zero then
+ Eop (Ocmp (Cmaskzero n1)) (t1 ::: Enil)
+ else
+ Eop (Ocmp (default c n2)) (e1 ::: Enil)
+ | Cne, Eop (Oandimm n1) (t1 ::: Enil) =>
+ if Int.eq_dec n2 Int.zero then
+ Eop (Ocmp (Cmasknotzero n1)) (t1 ::: Enil)
+ else
+ Eop (Ocmp (default c n2)) (e1 ::: Enil)
+ | _, _ =>
+ Eop (Ocmp (default c n2)) (e1 ::: Enil)
+ end.
+
+Nondetfunction comp (c: comparison) (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | Eop (Ointconst n1) Enil, t2 =>
+ compimm Ccompimm Int.cmp (swap_comparison c) t2 n1
+ | t1, Eop (Ointconst n2) Enil =>
+ compimm Ccompimm Int.cmp c t1 n2
+ | _, _ =>
+ Eop (Ocmp (Ccomp c)) (e1 ::: e2 ::: Enil)
+ end.
+
+Nondetfunction compu (c: comparison) (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | Eop (Ointconst n1) Enil, t2 =>
+ compimm Ccompuimm Int.cmpu (swap_comparison c) t2 n1
+ | t1, Eop (Ointconst n2) Enil =>
+ compimm Ccompuimm Int.cmpu c t1 n2
+ | _, _ =>
+ Eop (Ocmp (Ccompu c)) (e1 ::: e2 ::: Enil)
+ end.
+
+Definition compf (c: comparison) (e1: expr) (e2: expr) :=
+ Eop (Ocmp (Ccompf c)) (e1 ::: e2 ::: Enil).
+
+Definition compfs (c: comparison) (e1: expr) (e2: expr) :=
+ Eop (Ocmp (Ccompfs c)) (e1 ::: e2 ::: Enil).
+
+(** ** Integer conversions *)
+
+Nondetfunction cast8unsigned (e: expr) :=
+ match e with
+ | Eop (Ointconst n) Enil =>
+ Eop (Ointconst (Int.zero_ext 8 n)) Enil
+ | Eop (Oandimm n) (t:::Enil) =>
+ andimm (Int.and (Int.repr 255) n) t
+ | _ =>
+ Eop Ocast8unsigned (e:::Enil)
+ end.
+
+Nondetfunction cast8signed (e: expr) :=
+ match e with
+ | Eop (Ointconst n) Enil =>
+ Eop (Ointconst (Int.sign_ext 8 n)) Enil
+ | _ =>
+ Eop Ocast8signed (e ::: Enil)
+ end.
+
+Nondetfunction cast16unsigned (e: expr) :=
+ match e with
+ | Eop (Ointconst n) Enil =>
+ Eop (Ointconst (Int.zero_ext 16 n)) Enil
+ | Eop (Oandimm n) (t:::Enil) =>
+ andimm (Int.and (Int.repr 65535) n) t
+ | _ =>
+ Eop Ocast16unsigned (e:::Enil)
+ end.
+
+Nondetfunction cast16signed (e: expr) :=
+ match e with
+ | Eop (Ointconst n) Enil =>
+ Eop (Ointconst (Int.sign_ext 16 n)) Enil
+ | _ =>
+ Eop Ocast16signed (e ::: Enil)
+ end.
+
+(** Floating-point conversions *)
+
+Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil).
+Definition floatofsingle (e: expr) := Eop Ofloatofsingle (e ::: Enil).
+
+Definition intoffloat (e: expr) := Eop Ointoffloat (e ::: Enil).
+
+Nondetfunction floatofint (e: expr) :=
+ match e with
+ | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_int n)) Enil
+ | _ => Eop Ofloatofint (e ::: Enil)
+ end.
+
+Definition intuoffloat (e: expr) :=
+ Elet e
+ (Elet (Eop (Ofloatconst (Float.of_intu Float.ox8000_0000)) Enil)
+ (Econdition (CEcond (Ccompf Clt) (Eletvar 1 ::: Eletvar 0 ::: Enil))
+ (intoffloat (Eletvar 1))
+ (addimm Float.ox8000_0000 (intoffloat (subf (Eletvar 1) (Eletvar 0))))))%nat.
+
+Nondetfunction floatofintu (e: expr) :=
+ match e with
+ | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_intu n)) Enil
+ | _ =>
+ let f := Eop (Ofloatconst (Float.of_intu Float.ox8000_0000)) Enil in
+ Elet e
+ (Econdition (CEcond (Ccompuimm Clt Float.ox8000_0000) (Eletvar O ::: Enil))
+ (floatofint (Eletvar O))
+ (addf (floatofint (addimm (Int.neg Float.ox8000_0000) (Eletvar O))) f))
+ end.
+
+Definition intofsingle (e: expr) := Eop Ointofsingle (e ::: Enil).
+
+Nondetfunction singleofint (e: expr) :=
+ match e with
+ | Eop (Ointconst n) Enil => Eop (Osingleconst (Float32.of_int n)) Enil
+ | _ => Eop Osingleofint (e ::: Enil)
+ end.
+
+Definition intuofsingle (e: expr) := intuoffloat (floatofsingle e).
+
+Nondetfunction singleofintu (e: expr) :=
+ match e with
+ | Eop (Ointconst n) Enil => Eop (Osingleconst (Float32.of_intu n)) Enil
+ | _ => singleoffloat (floatofintu e)
+ end.
+
+(** ** Addressing modes *)
+
+Nondetfunction addressing (chunk: memory_chunk) (e: expr) :=
+ match e with
+ | Eop (Olea addr) args =>
+ if (negb Archi.ptr64) && addressing_valid addr then (addr, args) else (Aindexed 0, e:::Enil)
+ | Eop (Oleal addr) args =>
+ if Archi.ptr64 && addressing_valid addr then (addr, args) else (Aindexed 0, e:::Enil)
+ | _ => (Aindexed 0, e:::Enil)
+ end.
+
+(** ** Arguments of builtins *)
+
+Nondetfunction builtin_arg (e: expr) :=
+ match e with
+ | Eop (Ointconst n) Enil => BA_int n
+ | Eop (Olongconst n) Enil => BA_long n
+ | Eop (Olea (Aglobal id ofs)) Enil => if Archi.ptr64 then BA e else BA_addrglobal id ofs
+ | Eop (Olea (Ainstack ofs)) Enil => if Archi.ptr64 then BA e else BA_addrstack ofs
+ | Eop (Oleal (Aglobal id ofs)) Enil => if Archi.ptr64 then BA_addrglobal id ofs else BA e
+ | Eop (Oleal (Ainstack ofs)) Enil => if Archi.ptr64 then BA_addrstack ofs else BA e
+ | Eop Omakelong (Eop (Ointconst h) Enil ::: Eop (Ointconst l) Enil ::: Enil) =>
+ BA_long (Int64.ofwords h l)
+ | Eop Omakelong (h ::: l ::: Enil) => BA_splitlong (BA h) (BA l)
+ | Eload chunk (Aglobal id ofs) Enil => BA_loadglobal chunk id ofs
+ | Eload chunk (Ainstack ofs) Enil => BA_loadstack chunk ofs
+ | _ => BA e
+ end.
diff --git a/x86/SelectOpproof.v b/x86/SelectOpproof.v
new file mode 100644
index 00000000..ce15b6e1
--- /dev/null
+++ b/x86/SelectOpproof.v
@@ -0,0 +1,959 @@
+(* *********************************************************************)
+(* *)
+(* 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 for operators *)
+
+Require Import Coqlib.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Memory.
+Require Import Globalenvs.
+Require Import Cminor.
+Require Import Op.
+Require Import CminorSel.
+Require Import SelectOp.
+
+Open Local Scope cminorsel_scope.
+
+(** * 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 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; FuncInv
+ | [ 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; subst.
+
+Ltac TrivialExists :=
+ match goal with
+ | [ |- exists v, _ /\ Val.lessdef ?a v ] => exists a; split; [EvalOp | auto]
+ end.
+
+(** * Correctness of the smart constructors *)
+
+Section CMCONSTR.
+
+Variable ge: genv.
+Variable sp: val.
+Variable e: env.
+Variable m: mem.
+
+(** We now show that the code generated by "smart constructor" functions
+ such as [SelectOp.notint] behaves as expected. Continuing the
+ [notint] example, we show that if the expression [e]
+ evaluates to some integer value [Vint n], then [SelectOp.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.
+*)
+
+Definition unary_constructor_sound (cstr: expr -> expr) (sem: val -> val) : Prop :=
+ forall le a x,
+ eval_expr ge sp e m le a x ->
+ exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef (sem x) v.
+
+Definition binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> val) : Prop :=
+ forall le a x b y,
+ eval_expr ge sp e m le a x ->
+ eval_expr ge sp e m le b y ->
+ exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef (sem x y) v.
+
+Lemma eval_Olea_ptr:
+ forall a el m,
+ eval_operation ge sp (Olea_ptr a) el m = eval_addressing ge sp a el.
+Proof.
+ unfold Olea_ptr, eval_addressing; intros. destruct Archi.ptr64; auto.
+Qed.
+
+Theorem eval_addrsymbol:
+ forall le id ofs,
+ exists v, eval_expr ge sp e m le (addrsymbol id ofs) v /\ Val.lessdef (Genv.symbol_address ge id ofs) v.
+Proof.
+ intros. unfold addrsymbol. exists (Genv.symbol_address ge id ofs); split; auto.
+ destruct (symbol_is_external id).
+ predSpec Ptrofs.eq Ptrofs.eq_spec ofs Ptrofs.zero.
+ subst. EvalOp.
+ EvalOp. econstructor. EvalOp. simpl; eauto. econstructor.
+ unfold Olea_ptr; destruct Archi.ptr64 eqn:SF; simpl;
+ [ rewrite <- Genv.shift_symbol_address_64 by auto | rewrite <- Genv.shift_symbol_address_32 by auto ];
+ f_equal; f_equal;
+ rewrite Ptrofs.add_zero_l;
+ [ apply Ptrofs.of_int64_to_int64 | apply Ptrofs.of_int_to_int ];
+ auto.
+ EvalOp. (*rewrite eval_Olea_ptr. apply eval_addressing_Aglobal. *)
+Qed.
+
+Theorem eval_addrstack:
+ forall le ofs,
+ exists v, eval_expr ge sp e m le (addrstack ofs) v /\ Val.lessdef (Val.offset_ptr sp ofs) v.
+Proof.
+ intros. unfold addrstack. TrivialExists. (*rewrite eval_Olea_ptr. apply eval_addressing_Ainstack.*)
+Qed.
+
+Theorem eval_notint: unary_constructor_sound notint Val.notint.
+Proof.
+ unfold notint; red; intros until x. case (notint_match a); intros; InvEval.
+- TrivialExists.
+- rewrite Val.not_xor. rewrite Val.xor_assoc. TrivialExists.
+- TrivialExists.
+Qed.
+
+Theorem eval_addimm:
+ forall n, unary_constructor_sound (addimm n) (fun x => Val.add x (Vint n)).
+Proof.
+ red; unfold addimm; intros until x.
+ predSpec Int.eq Int.eq_spec n Int.zero.
+- subst n. intros. exists x; split; auto.
+ destruct x; simpl; rewrite ?Int.add_zero, ?Ptrofs.add_zero; auto.
+- case (addimm_match a); intros; InvEval.
++ TrivialExists; simpl. rewrite Int.add_commut. auto.
++ inv H0. simpl in H6. TrivialExists. simpl.
+ erewrite eval_offset_addressing_total_32 by eauto. rewrite Int.repr_signed; auto.
++ TrivialExists. simpl. rewrite Int.repr_signed; auto.
+Qed.
+
+Theorem eval_add: binary_constructor_sound add Val.add.
+Proof.
+ assert (A: forall x y, Int.repr (x + y) = Int.add (Int.repr x) (Int.repr y)).
+ { intros; apply Int.eqm_samerepr; auto with ints. }
+ assert (B: forall id ofs n, Archi.ptr64 = false ->
+ Genv.symbol_address ge id (Ptrofs.add ofs (Ptrofs.repr n)) =
+ Val.add (Genv.symbol_address ge id ofs) (Vint (Int.repr n))).
+ { intros. replace (Ptrofs.repr n) with (Ptrofs.of_int (Int.repr n)) by auto with ptrofs.
+ apply Genv.shift_symbol_address_32; auto. }
+ red; intros until y.
+ unfold add; case (add_match a b); intros; InvEval.
+- rewrite Val.add_commut. apply eval_addimm; auto.
+- apply eval_addimm; auto.
+- TrivialExists. simpl. rewrite A, Val.add_permut_4. auto.
+- TrivialExists. simpl. rewrite A, Val.add_assoc. decEq; decEq. rewrite Val.add_permut. auto.
+- TrivialExists. simpl. rewrite A, Val.add_permut_4. rewrite <- Val.add_permut. rewrite <- Val.add_assoc. auto.
+- TrivialExists. simpl. rewrite Heqb0. rewrite B by auto. rewrite ! Val.add_assoc.
+ rewrite (Val.add_commut v1). rewrite Val.add_permut. rewrite Val.add_assoc. auto.
+- TrivialExists. simpl. rewrite Heqb0. rewrite B by auto. rewrite Val.add_assoc. do 2 f_equal. apply Val.add_commut.
+- TrivialExists. simpl. rewrite Heqb0. rewrite B by auto. rewrite !Val.add_assoc.
+ rewrite (Val.add_commut (Vint (Int.repr n1))). rewrite Val.add_permut. do 2 f_equal. apply Val.add_commut.
+- TrivialExists. simpl. rewrite Heqb0. rewrite B by auto. rewrite !Val.add_assoc.
+ rewrite (Val.add_commut (Vint (Int.repr n2))). rewrite Val.add_permut. auto.
+- TrivialExists. simpl. rewrite Val.add_permut. rewrite Val.add_assoc.
+ decEq; decEq. apply Val.add_commut.
+- TrivialExists.
+- TrivialExists. simpl. repeat rewrite Val.add_assoc. decEq; decEq. apply Val.add_commut.
+- TrivialExists. simpl. rewrite Val.add_assoc; auto.
+- TrivialExists. simpl.
+ unfold Val.add; destruct Archi.ptr64, x, y; auto.
+ + rewrite Int.add_zero; auto.
+ + rewrite Int.add_zero; auto.
+ + rewrite Ptrofs.add_assoc, Ptrofs.add_zero. auto.
+ + rewrite Ptrofs.add_assoc, Ptrofs.add_zero. auto.
+Qed.
+
+Theorem eval_sub: binary_constructor_sound sub Val.sub.
+Proof.
+ red; intros until y.
+ unfold sub; case (sub_match a b); intros; InvEval.
+- rewrite Val.sub_add_opp. apply eval_addimm; auto.
+- rewrite Val.sub_add_l. rewrite Val.sub_add_r.
+ rewrite Val.add_assoc. simpl. rewrite Int.add_commut. rewrite <- Int.sub_add_opp.
+ replace (Int.repr (n1 - n2)) with (Int.sub (Int.repr n1) (Int.repr n2)).
+ apply eval_addimm; EvalOp.
+ apply Int.eqm_samerepr; auto with ints.
+- rewrite Val.sub_add_l. apply eval_addimm; EvalOp.
+- rewrite Val.sub_add_r. replace (Int.repr (-n2)) with (Int.neg (Int.repr n2)). apply eval_addimm; EvalOp.
+ apply Int.eqm_samerepr; auto with ints.
+- TrivialExists.
+Qed.
+
+Theorem eval_negint: unary_constructor_sound negint Val.neg.
+Proof.
+ red; intros until x. unfold negint. case (negint_match a); intros; InvEval.
+- TrivialExists.
+- TrivialExists.
+Qed.
+
+Theorem eval_shlimm:
+ forall n, unary_constructor_sound (fun a => shlimm a n)
+ (fun x => Val.shl x (Vint n)).
+Proof.
+ red; intros until x. unfold shlimm.
+ predSpec Int.eq Int.eq_spec n Int.zero.
+ intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shl_zero; auto.
+ destruct (Int.ltu n Int.iwordsize) eqn:LT; simpl.
+ destruct (shlimm_match a); intros; InvEval.
+- exists (Vint (Int.shl n1 n)); split. EvalOp.
+ simpl. rewrite LT. auto.
+- destruct (Int.ltu (Int.add n n1) Int.iwordsize) eqn:?.
++ exists (Val.shl v1 (Vint (Int.add n n1))); split. EvalOp.
+ destruct v1; simpl; auto.
+ rewrite Heqb.
+ destruct (Int.ltu n1 Int.iwordsize) eqn:?; simpl; auto.
+ destruct (Int.ltu n Int.iwordsize) eqn:?; simpl; auto.
+ rewrite Int.add_commut. rewrite Int.shl_shl; auto. rewrite Int.add_commut; auto.
++ TrivialExists. econstructor. EvalOp. simpl; eauto. constructor.
+ simpl. auto.
+- destruct (shift_is_scale n).
++ econstructor; split. EvalOp. simpl. eauto.
+ rewrite ! Int.repr_unsigned.
+ destruct v1; simpl; auto. rewrite LT.
+ rewrite Int.shl_mul. rewrite Int.mul_add_distr_l. rewrite (Int.shl_mul (Int.repr n1)). auto.
++ TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. auto.
+- destruct (shift_is_scale n).
++ econstructor; split. EvalOp. simpl. eauto.
+ destruct x; simpl; auto. rewrite LT.
+ rewrite Int.repr_unsigned. rewrite Int.add_zero. rewrite Int.shl_mul. auto.
++ TrivialExists.
+- intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor.
+ auto.
+Qed.
+
+Theorem eval_shruimm:
+ forall n, unary_constructor_sound (fun a => shruimm a n)
+ (fun x => Val.shru x (Vint n)).
+Proof.
+ red; intros until x. unfold shruimm.
+ predSpec Int.eq Int.eq_spec n Int.zero.
+ intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shru_zero; auto.
+ destruct (Int.ltu n Int.iwordsize) eqn:LT; simpl.
+ destruct (shruimm_match a); intros; InvEval.
+- exists (Vint (Int.shru n1 n)); split. EvalOp.
+ simpl. rewrite LT; auto.
+- destruct (Int.ltu (Int.add n n1) Int.iwordsize) eqn:?.
++ exists (Val.shru v1 (Vint (Int.add n n1))); split. EvalOp.
+ subst. destruct v1; simpl; auto.
+ rewrite Heqb.
+ destruct (Int.ltu n1 Int.iwordsize) eqn:?; simpl; auto.
+ rewrite LT. rewrite Int.add_commut. rewrite Int.shru_shru; auto. rewrite Int.add_commut; auto.
++ TrivialExists. econstructor. EvalOp. simpl; eauto. constructor.
+ simpl. auto.
+- TrivialExists.
+- intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor.
+ auto.
+Qed.
+
+Theorem eval_shrimm:
+ forall n, unary_constructor_sound (fun a => shrimm a n)
+ (fun x => Val.shr x (Vint n)).
+Proof.
+ red; intros until x. unfold shrimm.
+ predSpec Int.eq Int.eq_spec n Int.zero.
+ intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shr_zero; auto.
+ destruct (Int.ltu n Int.iwordsize) eqn:LT; simpl.
+ destruct (shrimm_match a); intros; InvEval.
+- exists (Vint (Int.shr n1 n)); split. EvalOp.
+ simpl. rewrite LT; auto.
+- destruct (Int.ltu (Int.add n n1) Int.iwordsize) eqn:?.
++ exists (Val.shr v1 (Vint (Int.add n n1))); split. EvalOp.
+ subst. destruct v1; simpl; auto.
+ rewrite Heqb.
+ destruct (Int.ltu n1 Int.iwordsize) eqn:?; simpl; auto.
+ rewrite LT.
+ rewrite Int.add_commut. rewrite Int.shr_shr; auto. rewrite Int.add_commut; auto.
++ TrivialExists. econstructor. EvalOp. simpl; eauto. constructor.
+ simpl. auto.
+- TrivialExists.
+- intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor.
+ auto.
+Qed.
+
+Lemma eval_mulimm_base:
+ forall n, unary_constructor_sound (mulimm_base n) (fun x => Val.mul x (Vint n)).
+Proof.
+ intros; red; intros; unfold mulimm_base.
+ generalize (Int.one_bits_decomp n) (Int.one_bits_range n); intros D R.
+ destruct (Int.one_bits n) as [ | i l].
+ TrivialExists.
+ destruct l as [ | j l ].
+ replace (Val.mul x (Vint n)) with (Val.shl x (Vint i)). apply eval_shlimm; auto.
+ destruct x; auto; simpl. rewrite D; simpl; rewrite Int.add_zero.
+ rewrite R by auto with coqlib. rewrite Int.shl_mul. auto.
+ destruct l as [ | k l ].
+ exploit (eval_shlimm i (x :: le) (Eletvar 0) x). constructor; auto. intros [v1 [A1 B1]].
+ exploit (eval_shlimm j (x :: le) (Eletvar 0) x). constructor; auto. intros [v2 [A2 B2]].
+ exploit eval_add. eexact A1. eexact A2. intros [v3 [A3 B3]].
+ exists v3; split. econstructor; eauto.
+ rewrite D; simpl; rewrite Int.add_zero.
+ replace (Vint (Int.add (Int.shl Int.one i) (Int.shl Int.one j)))
+ with (Val.add (Val.shl Vone (Vint i)) (Val.shl Vone (Vint j))).
+ rewrite Val.mul_add_distr_r.
+ repeat rewrite Val.shl_mul.
+ apply Val.lessdef_trans with (Val.add v1 v2); auto. apply Val.add_lessdef; auto.
+ simpl. rewrite ! R by auto with coqlib. auto.
+ TrivialExists.
+Qed.
+
+Theorem eval_mulimm:
+ forall n, unary_constructor_sound (mulimm n) (fun x => Val.mul x (Vint n)).
+Proof.
+ intros; red; intros until x; unfold mulimm.
+ predSpec Int.eq Int.eq_spec n Int.zero.
+ intros. exists (Vint Int.zero); split. EvalOp.
+ destruct x; simpl; auto. subst n. rewrite Int.mul_zero. auto.
+ predSpec Int.eq Int.eq_spec n Int.one.
+ intros. exists x; split; auto.
+ destruct x; simpl; auto. subst n. rewrite Int.mul_one. auto.
+- case (mulimm_match a); intros; InvEval.
++ TrivialExists. simpl. rewrite Int.mul_commut; auto.
++ rewrite Val.mul_add_distr_l.
+ exploit eval_mulimm_base; eauto. instantiate (1 := n). intros [v' [A1 B1]].
+ exploit (eval_addimm (Int.mul n (Int.repr n2)) le (mulimm_base n t2) v'). auto. intros [v'' [A2 B2]].
+ exists v''; split; auto. eapply Val.lessdef_trans. eapply Val.add_lessdef; eauto.
+ rewrite Val.mul_commut; auto.
++ apply eval_mulimm_base; auto.
+Qed.
+
+Theorem eval_mul: binary_constructor_sound mul Val.mul.
+Proof.
+ red; intros until y.
+ unfold mul; case (mul_match a b); intros; InvEval.
+- rewrite Val.mul_commut. apply eval_mulimm. auto.
+- apply eval_mulimm. auto.
+- TrivialExists.
+Qed.
+
+Theorem eval_andimm:
+ forall n, unary_constructor_sound (andimm n) (fun x => Val.and x (Vint n)).
+Proof.
+ intros; red; intros until x. unfold andimm.
+ predSpec Int.eq Int.eq_spec n Int.zero.
+ intros. exists (Vint Int.zero); split. EvalOp.
+ destruct x; simpl; auto. subst n. rewrite Int.and_zero. auto.
+ predSpec Int.eq Int.eq_spec n Int.mone.
+ intros. exists x; split; auto.
+ destruct x; simpl; auto. subst n. rewrite Int.and_mone. auto.
+ case (andimm_match a); intros; InvEval.
+- TrivialExists. simpl. rewrite Int.and_commut; auto.
+- TrivialExists. simpl. rewrite Val.and_assoc. rewrite Int.and_commut. auto.
+- rewrite Val.zero_ext_and. TrivialExists. rewrite Val.and_assoc.
+ rewrite Int.and_commut. auto. compute; auto.
+- rewrite Val.zero_ext_and. TrivialExists. rewrite Val.and_assoc.
+ rewrite Int.and_commut. auto. compute; auto.
+- TrivialExists.
+Qed.
+
+Theorem eval_and: binary_constructor_sound and Val.and.
+Proof.
+ red; intros until y; unfold and; case (and_match a b); intros; InvEval.
+- rewrite Val.and_commut. apply eval_andimm; auto.
+- apply eval_andimm; auto.
+- TrivialExists.
+Qed.
+
+Theorem eval_orimm:
+ forall n, unary_constructor_sound (orimm n) (fun x => Val.or x (Vint n)).
+Proof.
+ intros; red; intros until x. unfold orimm.
+ predSpec Int.eq Int.eq_spec n Int.zero.
+ intros. exists x; split. auto.
+ destruct x; simpl; auto. subst n. rewrite Int.or_zero. auto.
+ predSpec Int.eq Int.eq_spec n Int.mone.
+ intros. exists (Vint Int.mone); split. EvalOp.
+ destruct x; simpl; auto. subst n. rewrite Int.or_mone. auto.
+ destruct (orimm_match a); intros; InvEval.
+- TrivialExists. simpl. rewrite Int.or_commut; auto.
+- subst. rewrite Val.or_assoc. simpl. rewrite Int.or_commut. TrivialExists.
+- TrivialExists.
+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.
+
+Remark int_add_sub_eq:
+ forall x y z, Int.add x y = z -> Int.sub z x = y.
+Proof.
+ intros. subst z. rewrite Int.sub_add_l. rewrite Int.sub_idem. apply Int.add_zero_l.
+Qed.
+
+Lemma eval_or: binary_constructor_sound or Val.or.
+Proof.
+ red; intros until y; unfold or; case (or_match a b); intros.
+ (* intconst *)
+- InvEval. rewrite Val.or_commut. apply eval_orimm; auto.
+- InvEval. apply eval_orimm; auto.
+- (* shlimm - shruimm *)
+ predSpec Int.eq Int.eq_spec (Int.add n1 n2) Int.iwordsize.
+ destruct (same_expr_pure t1 t2) eqn:?.
+ InvEval. exploit eval_same_expr; eauto. intros [EQ1 EQ2]; subst.
+ exists (Val.ror v0 (Vint n2)); split. EvalOp.
+ destruct v0; simpl; auto.
+ destruct (Int.ltu n1 Int.iwordsize) eqn:?; auto.
+ destruct (Int.ltu n2 Int.iwordsize) eqn:?; auto.
+ simpl. rewrite <- Int.or_ror; auto.
+ InvEval. econstructor; split; eauto. EvalOp.
+ simpl. erewrite int_add_sub_eq; eauto.
+ TrivialExists.
+- (* shruimm - shlimm *)
+ predSpec Int.eq Int.eq_spec (Int.add n1 n2) Int.iwordsize.
+ destruct (same_expr_pure t1 t2) eqn:?.
+ InvEval. exploit eval_same_expr; eauto. intros [EQ1 EQ2]; subst.
+ exists (Val.ror v1 (Vint n2)); split. EvalOp.
+ destruct v1; simpl; auto.
+ destruct (Int.ltu n2 Int.iwordsize) eqn:?; auto.
+ destruct (Int.ltu n1 Int.iwordsize) eqn:?; auto.
+ simpl. rewrite Int.or_commut. rewrite <- Int.or_ror; auto.
+ InvEval. econstructor; split; eauto. EvalOp.
+ simpl. erewrite int_add_sub_eq; eauto.
+ rewrite Val.or_commut; auto.
+ TrivialExists.
+- (* default *)
+ TrivialExists.
+Qed.
+
+Theorem eval_xorimm:
+ forall n, unary_constructor_sound (xorimm n) (fun x => Val.xor x (Vint n)).
+Proof.
+ intros; red; intros until x. unfold xorimm.
+ predSpec Int.eq Int.eq_spec n Int.zero.
+ intros. exists x; split. auto.
+ destruct x; simpl; auto. subst n. rewrite Int.xor_zero. auto.
+ destruct (xorimm_match a); intros; InvEval.
+- TrivialExists. simpl. rewrite Int.xor_commut; auto.
+- rewrite Val.xor_assoc. simpl. rewrite Int.xor_commut. TrivialExists.
+- rewrite Val.not_xor. rewrite Val.xor_assoc.
+ rewrite (Val.xor_commut (Vint Int.mone)). TrivialExists.
+- TrivialExists.
+Qed.
+
+Theorem eval_xor: binary_constructor_sound xor Val.xor.
+Proof.
+ red; intros until y; unfold xor; case (xor_match a b); intros; InvEval.
+- rewrite Val.xor_commut. apply eval_xorimm; auto.
+- apply eval_xorimm; auto.
+- TrivialExists.
+Qed.
+
+Theorem eval_divs_base:
+ forall le a b x y z,
+ eval_expr ge sp e m le a x ->
+ eval_expr ge sp e m le b y ->
+ Val.divs x y = Some z ->
+ exists v, eval_expr ge sp e m le (divs_base a b) v /\ Val.lessdef z v.
+Proof.
+ intros. unfold divs_base. exists z; split. EvalOp. auto.
+Qed.
+
+Theorem eval_divu_base:
+ forall le a b x y z,
+ eval_expr ge sp e m le a x ->
+ eval_expr ge sp e m le b y ->
+ Val.divu x y = Some z ->
+ exists v, eval_expr ge sp e m le (divu_base a b) v /\ Val.lessdef z v.
+Proof.
+ intros. unfold divu_base. exists z; split. EvalOp. auto.
+Qed.
+
+Theorem eval_mods_base:
+ forall le a b x y z,
+ eval_expr ge sp e m le a x ->
+ eval_expr ge sp e m le b y ->
+ Val.mods x y = Some z ->
+ exists v, eval_expr ge sp e m le (mods_base a b) v /\ Val.lessdef z v.
+Proof.
+ intros. unfold mods_base. exists z; split. EvalOp. auto.
+Qed.
+
+Theorem eval_modu_base:
+ forall le a b x y z,
+ eval_expr ge sp e m le a x ->
+ eval_expr ge sp e m le b y ->
+ Val.modu x y = Some z ->
+ exists v, eval_expr ge sp e m le (modu_base a b) v /\ Val.lessdef z v.
+Proof.
+ intros. unfold modu_base. exists z; split. EvalOp. auto.
+Qed.
+
+Theorem eval_shrximm:
+ forall le a n x z,
+ eval_expr ge sp e m le a x ->
+ Val.shrx x (Vint n) = Some z ->
+ exists v, eval_expr ge sp e m le (shrximm a n) v /\ Val.lessdef z v.
+Proof.
+ intros. unfold shrximm.
+ predSpec Int.eq Int.eq_spec n Int.zero.
+ subst n. exists x; split; auto.
+ destruct x; simpl in H0; try discriminate.
+ destruct (Int.ltu Int.zero (Int.repr 31)); inv H0.
+ replace (Int.shrx i Int.zero) with i. auto.
+ unfold Int.shrx, Int.divs. rewrite Int.shl_zero.
+ change (Int.signed Int.one) with 1. rewrite Z.quot_1_r. rewrite Int.repr_signed; auto.
+ econstructor; split. EvalOp. auto.
+Qed.
+
+Theorem eval_shl: binary_constructor_sound shl Val.shl.
+Proof.
+ red; intros until y; unfold shl; case (shl_match b); intros.
+- InvEval. apply eval_shlimm; auto.
+- TrivialExists.
+Qed.
+
+Theorem eval_shr: binary_constructor_sound shr Val.shr.
+Proof.
+ red; intros until y; unfold shr; case (shr_match b); intros.
+- InvEval. apply eval_shrimm; auto.
+- TrivialExists.
+Qed.
+
+Theorem eval_shru: binary_constructor_sound shru Val.shru.
+Proof.
+ red; intros until y; unfold shru; case (shru_match b); intros.
+- InvEval. apply eval_shruimm; auto.
+- TrivialExists.
+Qed.
+
+Theorem eval_negf: unary_constructor_sound negf Val.negf.
+Proof.
+ red; intros. TrivialExists.
+Qed.
+
+Theorem eval_absf: unary_constructor_sound absf Val.absf.
+Proof.
+ red; intros. TrivialExists.
+Qed.
+
+Theorem eval_addf: binary_constructor_sound addf Val.addf.
+Proof.
+ red; intros; TrivialExists.
+Qed.
+
+Theorem eval_subf: binary_constructor_sound subf Val.subf.
+Proof.
+ red; intros; TrivialExists.
+Qed.
+
+Theorem eval_mulf: binary_constructor_sound mulf Val.mulf.
+Proof.
+ red; intros; TrivialExists.
+Qed.
+
+Theorem eval_negfs: unary_constructor_sound negfs Val.negfs.
+Proof.
+ red; intros. TrivialExists.
+Qed.
+
+Theorem eval_absfs: unary_constructor_sound absfs Val.absfs.
+Proof.
+ red; intros. TrivialExists.
+Qed.
+
+Theorem eval_addfs: binary_constructor_sound addfs Val.addfs.
+Proof.
+ red; intros; TrivialExists.
+Qed.
+
+Theorem eval_subfs: binary_constructor_sound subfs Val.subfs.
+Proof.
+ red; intros; TrivialExists.
+Qed.
+
+Theorem eval_mulfs: binary_constructor_sound mulfs Val.mulfs.
+Proof.
+ red; intros; TrivialExists.
+Qed.
+
+Section COMP_IMM.
+
+Variable default: comparison -> int -> condition.
+Variable intsem: comparison -> int -> int -> bool.
+Variable sem: comparison -> val -> val -> val.
+
+Hypothesis sem_int: forall c x y, sem c (Vint x) (Vint y) = Val.of_bool (intsem c x y).
+Hypothesis sem_undef: forall c v, sem c Vundef v = Vundef.
+Hypothesis sem_eq: forall x y, sem Ceq (Vint x) (Vint y) = Val.of_bool (Int.eq x y).
+Hypothesis sem_ne: forall x y, sem Cne (Vint x) (Vint y) = Val.of_bool (negb (Int.eq x y)).
+Hypothesis sem_default: forall c v n, sem c v (Vint n) = Val.of_optbool (eval_condition (default c n) (v :: nil) m).
+
+Lemma eval_compimm:
+ forall le c a n2 x,
+ eval_expr ge sp e m le a x ->
+ exists v, eval_expr ge sp e m le (compimm default intsem c a n2) v
+ /\ Val.lessdef (sem c x (Vint n2)) v.
+Proof.
+ intros until x.
+ unfold compimm; case (compimm_match c a); intros.
+- (* constant *)
+ InvEval. rewrite sem_int. TrivialExists. simpl. destruct (intsem c0 n1 n2); auto.
+- (* eq cmp *)
+ InvEval. inv H. simpl in H5. inv H5.
+ destruct (Int.eq_dec n2 Int.zero). subst n2. TrivialExists.
+ simpl. rewrite eval_negate_condition.
+ destruct (eval_condition c0 vl m); simpl.
+ unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_eq; auto.
+ rewrite sem_undef; auto.
+ destruct (Int.eq_dec n2 Int.one). subst n2. TrivialExists.
+ simpl. destruct (eval_condition c0 vl m); simpl.
+ unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_eq; auto.
+ rewrite sem_undef; auto.
+ exists (Vint Int.zero); split. EvalOp.
+ destruct (eval_condition c0 vl m); simpl.
+ unfold Vtrue, Vfalse. destruct b; rewrite sem_eq; rewrite Int.eq_false; auto.
+ rewrite sem_undef; auto.
+- (* ne cmp *)
+ InvEval. inv H. simpl in H5. inv H5.
+ destruct (Int.eq_dec n2 Int.zero). subst n2. TrivialExists.
+ simpl. destruct (eval_condition c0 vl m); simpl.
+ unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_ne; auto.
+ rewrite sem_undef; auto.
+ destruct (Int.eq_dec n2 Int.one). subst n2. TrivialExists.
+ simpl. rewrite eval_negate_condition. destruct (eval_condition c0 vl m); simpl.
+ unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_ne; auto.
+ rewrite sem_undef; auto.
+ exists (Vint Int.one); split. EvalOp.
+ destruct (eval_condition c0 vl m); simpl.
+ unfold Vtrue, Vfalse. destruct b; rewrite sem_ne; rewrite Int.eq_false; auto.
+ rewrite sem_undef; auto.
+- (* eq andimm *)
+ destruct (Int.eq_dec n2 Int.zero). InvEval; subst.
+ econstructor; split. EvalOp. simpl; eauto.
+ destruct v1; simpl; try (rewrite sem_undef; auto). rewrite sem_eq.
+ destruct (Int.eq (Int.and i n1) Int.zero); auto.
+ TrivialExists. simpl. rewrite sem_default. auto.
+- (* ne andimm *)
+ destruct (Int.eq_dec n2 Int.zero). InvEval; subst.
+ econstructor; split. EvalOp. simpl; eauto.
+ destruct v1; simpl; try (rewrite sem_undef; auto). rewrite sem_ne.
+ destruct (Int.eq (Int.and i n1) Int.zero); auto.
+ TrivialExists. simpl. rewrite sem_default. auto.
+- (* default *)
+ TrivialExists. simpl. rewrite sem_default. auto.
+Qed.
+
+Hypothesis sem_swap:
+ forall c x y, sem (swap_comparison c) x y = sem c y x.
+
+Lemma eval_compimm_swap:
+ forall le c a n2 x,
+ eval_expr ge sp e m le a x ->
+ exists v, eval_expr ge sp e m le (compimm default intsem (swap_comparison c) a n2) v
+ /\ Val.lessdef (sem c (Vint n2) x) v.
+Proof.
+ intros. rewrite <- sem_swap. eapply eval_compimm; eauto.
+Qed.
+
+End COMP_IMM.
+
+Theorem eval_comp:
+ forall c, binary_constructor_sound (comp c) (Val.cmp c).
+Proof.
+ intros; red; intros until y. unfold comp; case (comp_match a b); intros; InvEval.
+ eapply eval_compimm_swap; eauto.
+ intros. unfold Val.cmp. rewrite Val.swap_cmp_bool; auto.
+ eapply eval_compimm; eauto.
+ TrivialExists.
+Qed.
+
+Theorem eval_compu:
+ forall c, binary_constructor_sound (compu c) (Val.cmpu (Mem.valid_pointer m) c).
+Proof.
+ intros; red; intros until y. unfold compu; case (compu_match a b); intros; InvEval.
+ eapply eval_compimm_swap; eauto.
+ intros. unfold Val.cmpu. rewrite Val.swap_cmpu_bool; auto.
+ eapply eval_compimm; eauto.
+ TrivialExists.
+Qed.
+
+Theorem eval_compf:
+ forall c, binary_constructor_sound (compf c) (Val.cmpf c).
+Proof.
+ intros; red; intros. unfold compf. TrivialExists.
+Qed.
+
+Theorem eval_compfs:
+ forall c, binary_constructor_sound (compfs c) (Val.cmpfs c).
+Proof.
+ intros; red; intros. unfold compfs. TrivialExists.
+Qed.
+
+Theorem eval_cast8signed: unary_constructor_sound cast8signed (Val.sign_ext 8).
+Proof.
+ red; intros until x. unfold cast8signed. case (cast8signed_match a); intros; InvEval.
+ TrivialExists.
+ TrivialExists.
+Qed.
+
+Theorem eval_cast8unsigned: unary_constructor_sound cast8unsigned (Val.zero_ext 8).
+Proof.
+ red; intros until x. unfold cast8unsigned. destruct (cast8unsigned_match a); intros; InvEval.
+ TrivialExists.
+ subst. rewrite Val.zero_ext_and. rewrite Val.and_assoc.
+ rewrite Int.and_commut. apply eval_andimm; auto. compute; auto.
+ TrivialExists.
+Qed.
+
+Theorem eval_cast16signed: unary_constructor_sound cast16signed (Val.sign_ext 16).
+Proof.
+ red; intros until x. unfold cast16signed. case (cast16signed_match a); intros; InvEval.
+ TrivialExists.
+ TrivialExists.
+Qed.
+
+Theorem eval_cast16unsigned: unary_constructor_sound cast16unsigned (Val.zero_ext 16).
+Proof.
+ red; intros until x. unfold cast16unsigned. destruct (cast16unsigned_match a); intros; InvEval.
+ TrivialExists.
+ subst. rewrite Val.zero_ext_and. rewrite Val.and_assoc.
+ rewrite Int.and_commut. apply eval_andimm; auto. compute; auto.
+ TrivialExists.
+Qed.
+
+Theorem eval_singleoffloat: unary_constructor_sound singleoffloat Val.singleoffloat.
+Proof.
+ red; intros. unfold singleoffloat. TrivialExists.
+Qed.
+
+Theorem eval_floatofsingle: unary_constructor_sound floatofsingle Val.floatofsingle.
+Proof.
+ red; intros. unfold floatofsingle. TrivialExists.
+Qed.
+
+Theorem eval_intoffloat:
+ forall le a x y,
+ eval_expr ge sp e m le a x ->
+ Val.intoffloat x = Some y ->
+ exists v, eval_expr ge sp e m le (intoffloat a) v /\ Val.lessdef y v.
+Proof.
+ intros; unfold intoffloat. TrivialExists.
+Qed.
+
+Theorem eval_floatofint:
+ forall le a x y,
+ eval_expr ge sp e m le a x ->
+ Val.floatofint x = Some y ->
+ exists v, eval_expr ge sp e m le (floatofint a) v /\ Val.lessdef y v.
+Proof.
+ intros until y; unfold floatofint. case (floatofint_match a); intros; InvEval.
+ TrivialExists.
+ TrivialExists.
+Qed.
+
+Theorem eval_intuoffloat:
+ forall le a x y,
+ eval_expr ge sp e m le a x ->
+ Val.intuoffloat x = Some y ->
+ exists v, eval_expr ge sp e m le (intuoffloat a) v /\ Val.lessdef y v.
+Proof.
+ intros. destruct x; simpl in H0; try discriminate.
+ destruct (Float.to_intu f) as [n|] eqn:?; simpl in H0; inv H0.
+ exists (Vint n); split; auto. unfold intuoffloat.
+ set (im := Int.repr Int.half_modulus).
+ set (fm := Float.of_intu im).
+ assert (eval_expr ge sp e m (Vfloat fm :: Vfloat f :: le) (Eletvar (S O)) (Vfloat f)).
+ constructor. auto.
+ assert (eval_expr ge sp e m (Vfloat fm :: Vfloat f :: le) (Eletvar O) (Vfloat fm)).
+ constructor. auto.
+ econstructor. eauto.
+ econstructor. instantiate (1 := Vfloat fm). EvalOp.
+ eapply eval_Econdition with (va := Float.cmp Clt f fm).
+ eauto with evalexpr.
+ destruct (Float.cmp Clt f fm) eqn:?.
+ exploit Float.to_intu_to_int_1; eauto. intro EQ.
+ EvalOp. simpl. rewrite EQ; auto.
+ exploit Float.to_intu_to_int_2; eauto.
+ change Float.ox8000_0000 with im. fold fm. intro EQ.
+ set (t2 := subf (Eletvar (S O)) (Eletvar O)).
+ set (t3 := intoffloat t2).
+ exploit (eval_subf (Vfloat fm :: Vfloat f :: le) (Eletvar (S O)) (Vfloat f) (Eletvar O)); eauto.
+ fold t2. intros [v2 [A2 B2]]. simpl in B2. inv B2.
+ exploit (eval_addimm Float.ox8000_0000 (Vfloat fm :: Vfloat f :: le) t3).
+ unfold t3. unfold intoffloat. EvalOp. simpl. rewrite EQ. simpl. eauto.
+ intros [v4 [A4 B4]]. simpl in B4. inv B4.
+ rewrite Int.sub_add_opp in A4. rewrite Int.add_assoc in A4.
+ rewrite (Int.add_commut (Int.neg im)) in A4.
+ rewrite Int.add_neg_zero in A4.
+ rewrite Int.add_zero in A4.
+ auto.
+Qed.
+
+Theorem eval_floatofintu:
+ forall le a x y,
+ eval_expr ge sp e m le a x ->
+ Val.floatofintu x = Some y ->
+ exists v, eval_expr ge sp e m le (floatofintu a) v /\ Val.lessdef y v.
+Proof.
+ intros until y; unfold floatofintu. case (floatofintu_match a); intros.
+ InvEval. TrivialExists.
+ destruct x; simpl in H0; try discriminate. inv H0.
+ exists (Vfloat (Float.of_intu i)); split; auto.
+ econstructor. eauto.
+ set (fm := Float.of_intu Float.ox8000_0000).
+ assert (eval_expr ge sp e m (Vint i :: le) (Eletvar O) (Vint i)).
+ constructor. auto.
+ eapply eval_Econdition with (va := Int.ltu i Float.ox8000_0000).
+ eauto with evalexpr.
+ destruct (Int.ltu i Float.ox8000_0000) eqn:?.
+ rewrite Float.of_intu_of_int_1; auto.
+ unfold floatofint. EvalOp.
+ exploit (eval_addimm (Int.neg Float.ox8000_0000) (Vint i :: le) (Eletvar 0)); eauto.
+ simpl. intros [v [A B]]. inv B.
+ unfold addf. EvalOp.
+ constructor. unfold floatofint. EvalOp. simpl; eauto.
+ constructor. EvalOp. simpl; eauto. constructor. simpl; eauto.
+ fold fm. rewrite Float.of_intu_of_int_2; auto.
+ rewrite Int.sub_add_opp. auto.
+Qed.
+
+Theorem eval_intofsingle:
+ forall le a x y,
+ eval_expr ge sp e m le a x ->
+ Val.intofsingle x = Some y ->
+ exists v, eval_expr ge sp e m le (intofsingle a) v /\ Val.lessdef y v.
+Proof.
+ intros; unfold intofsingle. TrivialExists.
+Qed.
+
+Theorem eval_singleofint:
+ forall le a x y,
+ eval_expr ge sp e m le a x ->
+ Val.singleofint x = Some y ->
+ exists v, eval_expr ge sp e m le (singleofint a) v /\ Val.lessdef y v.
+Proof.
+ intros until y; unfold singleofint. case (singleofint_match a); intros; InvEval.
+ TrivialExists.
+ TrivialExists.
+Qed.
+
+Theorem eval_intuofsingle:
+ forall le a x y,
+ eval_expr ge sp e m le a x ->
+ Val.intuofsingle x = Some y ->
+ exists v, eval_expr ge sp e m le (intuofsingle a) v /\ Val.lessdef y v.
+Proof.
+ intros. destruct x; simpl in H0; try discriminate.
+ destruct (Float32.to_intu f) as [n|] eqn:?; simpl in H0; inv H0.
+ unfold intuofsingle. apply eval_intuoffloat with (Vfloat (Float.of_single f)).
+ unfold floatofsingle. EvalOp.
+ simpl. change (Float.of_single f) with (Float32.to_double f).
+ erewrite Float32.to_intu_double; eauto. auto.
+Qed.
+
+Theorem eval_singleofintu:
+ forall le a x y,
+ eval_expr ge sp e m le a x ->
+ Val.singleofintu x = Some y ->
+ exists v, eval_expr ge sp e m le (singleofintu a) v /\ Val.lessdef y v.
+Proof.
+ intros until y; unfold singleofintu. case (singleofintu_match a); intros.
+ InvEval. TrivialExists.
+ destruct x; simpl in H0; try discriminate. inv H0.
+ exploit eval_floatofintu. eauto. simpl. reflexivity.
+ intros (v & A & B).
+ exists (Val.singleoffloat v); split.
+ unfold singleoffloat; EvalOp.
+ inv B; simpl. rewrite Float32.of_intu_double. auto.
+Qed.
+
+Theorem eval_addressing:
+ forall le chunk a v b ofs,
+ eval_expr ge sp e m le a v ->
+ v = Vptr b ofs ->
+ match addressing chunk 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 ofs.
+ assert (A: v = Vptr b ofs -> eval_addressing ge sp (Aindexed 0) (v :: nil) = Some v).
+ { intros. subst v. unfold eval_addressing.
+ destruct Archi.ptr64 eqn:SF; simpl; rewrite SF; rewrite Ptrofs.add_zero; auto. }
+ assert (D: forall a,
+ eval_expr ge sp e m le a v ->
+ v = Vptr b ofs ->
+ exists vl, eval_exprlist ge sp e m le (a ::: Enil) vl
+ /\ eval_addressing ge sp (Aindexed 0) vl = Some v).
+ { intros. exists (v :: nil); split. constructor; auto. constructor. auto. }
+ unfold addressing; case (addressing_match a); intros.
+- destruct (negb Archi.ptr64 && addressing_valid addr) eqn:E.
++ inv H. InvBooleans. apply negb_true_iff in H. unfold eval_addressing; rewrite H.
+ exists vl; auto.
++ apply D; auto.
+- destruct (Archi.ptr64 && addressing_valid addr) eqn:E.
++ inv H. InvBooleans. unfold eval_addressing; rewrite H.
+ exists vl; auto.
++ apply D; auto.
+- apply D; auto.
+Qed.
+
+Theorem eval_builtin_arg:
+ forall a v,
+ eval_expr ge sp e m nil a v ->
+ CminorSel.eval_builtin_arg ge sp e m (builtin_arg a) v.
+Proof.
+ intros until v. unfold builtin_arg; case (builtin_arg_match a); intros; InvEval.
+- constructor.
+- constructor.
+- constructor.
+- constructor.
+- constructor.
+- constructor.
+- simpl in H5. inv H5. constructor.
+- constructor; auto.
+- inv H. InvEval. rewrite eval_addressing_Aglobal in H6. inv H6. constructor; auto.
+- inv H. InvEval. rewrite eval_addressing_Ainstack in H6. inv H6. constructor; auto.
+- constructor; auto.
+Qed.
+
+End CMCONSTR.
diff --git a/x86/Stacklayout.v b/x86/Stacklayout.v
new file mode 100644
index 00000000..44fd43b2
--- /dev/null
+++ b/x86/Stacklayout.v
@@ -0,0 +1,148 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris *)
+(* *)
+(* 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 AST Memory Separation.
+Require Import Bounds.
+
+Local Open Scope sep_scope.
+
+(** The general shape of activation records is as follows,
+ from bottom (lowest offsets) to top:
+- Space for outgoing arguments to function calls.
+- Back link to parent frame
+- Saved values of integer callee-save registers used by the function.
+- Saved values of float callee-save registers used by the function.
+- Local stack slots.
+- Space for the stack-allocated data declared in Cminor
+- Return address.
+*)
+
+Definition fe_ofs_arg := 0.
+
+Definition make_env (b: bounds) : frame_env :=
+ let w := if Archi.ptr64 then 8 else 4 in
+ let olink := align (4 * b.(bound_outgoing)) w in (* back link *)
+ let ocs := olink + w in (* callee-saves *)
+ let ol := align (size_callee_save_area b ocs) 8 in (* locals *)
+ let ostkdata := align (ol + 4 * b.(bound_local)) 8 in (* stack data *)
+ let oretaddr := align (ostkdata + b.(bound_stack_data)) w in (* return address *)
+ let sz := oretaddr + w in (* total size *)
+ {| fe_size := sz;
+ fe_ofs_link := olink;
+ fe_ofs_retaddr := oretaddr;
+ fe_ofs_local := ol;
+ fe_ofs_callee_save := ocs;
+ fe_stack_data := ostkdata;
+ fe_used_callee_save := b.(used_callee_save) |}.
+
+Lemma frame_env_separated:
+ forall b sp m P,
+ let fe := make_env b in
+ m |= range sp 0 (fe_stack_data fe) ** range sp (fe_stack_data fe + bound_stack_data b) (fe_size fe) ** P ->
+ m |= range sp (fe_ofs_local fe) (fe_ofs_local fe + 4 * bound_local b)
+ ** range sp fe_ofs_arg (fe_ofs_arg + 4 * bound_outgoing b)
+ ** range sp (fe_ofs_link fe) (fe_ofs_link fe + size_chunk Mptr)
+ ** range sp (fe_ofs_retaddr fe) (fe_ofs_retaddr fe + size_chunk Mptr)
+ ** range sp (fe_ofs_callee_save fe) (size_callee_save_area b (fe_ofs_callee_save fe))
+ ** P.
+Proof.
+Local Opaque Z.add Z.mul sepconj range.
+ intros; simpl.
+ set (w := if Archi.ptr64 then 8 else 4).
+ set (olink := align (4 * b.(bound_outgoing)) w).
+ set (ocs := olink + w).
+ set (ol := align (size_callee_save_area b ocs) 8).
+ set (ostkdata := align (ol + 4 * b.(bound_local)) 8).
+ set (oretaddr := align (ostkdata + b.(bound_stack_data)) w).
+ replace (size_chunk Mptr) with w by (rewrite size_chunk_Mptr; auto).
+ assert (0 < w) by (unfold w; destruct Archi.ptr64; omega).
+ generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros.
+ assert (0 <= 4 * b.(bound_outgoing)) by omega.
+ assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; omega).
+ assert (olink + w <= ocs) by (unfold ocs; omega).
+ assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr).
+ assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega).
+ assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega).
+ assert (ostkdata + bound_stack_data b <= oretaddr) by (apply align_le; omega).
+(* Reorder as:
+ outgoing
+ back link
+ callee-save
+ local
+ retaddr *)
+ rewrite sep_swap12.
+ rewrite sep_swap23.
+ rewrite sep_swap45.
+ rewrite sep_swap34.
+(* Apply range_split and range_split2 repeatedly *)
+ unfold fe_ofs_arg.
+ apply range_split_2. fold olink. omega. omega.
+ apply range_split. omega.
+ apply range_split_2. fold ol. omega. omega.
+ apply range_drop_right with ostkdata. omega.
+ rewrite sep_swap.
+ apply range_drop_left with (ostkdata + bound_stack_data b). omega.
+ rewrite sep_swap.
+ exact H.
+Qed.
+
+Lemma frame_env_range:
+ forall b,
+ let fe := make_env b in
+ 0 <= fe_stack_data fe /\ fe_stack_data fe + bound_stack_data b <= fe_size fe.
+Proof.
+ intros; simpl.
+ set (w := if Archi.ptr64 then 8 else 4).
+ set (olink := align (4 * b.(bound_outgoing)) w).
+ set (ocs := olink + w).
+ set (ol := align (size_callee_save_area b ocs) 8).
+ set (ostkdata := align (ol + 4 * b.(bound_local)) 8).
+ set (oretaddr := align (ostkdata + b.(bound_stack_data)) w).
+ assert (0 < w) by (unfold w; destruct Archi.ptr64; omega).
+ generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros.
+ assert (0 <= 4 * b.(bound_outgoing)) by omega.
+ assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; omega).
+ assert (olink + w <= ocs) by (unfold ocs; omega).
+ assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr).
+ assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega).
+ assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega).
+ assert (ostkdata + bound_stack_data b <= oretaddr) by (apply align_le; omega).
+ split. omega. omega.
+Qed.
+
+Lemma frame_env_aligned:
+ forall b,
+ let fe := make_env b in
+ (8 | fe_ofs_arg)
+ /\ (8 | fe_ofs_local fe)
+ /\ (8 | fe_stack_data fe)
+ /\ (align_chunk Mptr | fe_ofs_link fe)
+ /\ (align_chunk Mptr | fe_ofs_retaddr fe).
+Proof.
+ intros; simpl.
+ set (w := if Archi.ptr64 then 8 else 4).
+ set (olink := align (4 * b.(bound_outgoing)) w).
+ set (ocs := olink + w).
+ set (ol := align (size_callee_save_area b ocs) 8).
+ set (ostkdata := align (ol + 4 * b.(bound_local)) 8).
+ set (oretaddr := align (ostkdata + b.(bound_stack_data)) w).
+ assert (0 < w) by (unfold w; destruct Archi.ptr64; omega).
+ replace (align_chunk Mptr) with w by (rewrite align_chunk_Mptr; auto).
+ split. apply Zdivide_0.
+ split. apply align_divides; omega.
+ split. apply align_divides; omega.
+ split. apply align_divides; omega.
+ apply align_divides; omega.
+Qed.
diff --git a/x86/TargetPrinter.ml b/x86/TargetPrinter.ml
new file mode 100644
index 00000000..33d47830
--- /dev/null
+++ b/x86/TargetPrinter.ml
@@ -0,0 +1,881 @@
+(* *********************************************************************)
+(* *)
+(* 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 x86-64 assembly code in asm syntax *)
+
+open Printf
+open !Datatypes
+open Camlcoq
+open Sections
+open AST
+open Asm
+open PrintAsmaux
+open Fileinfo
+
+module StringSet = Set.Make(String)
+
+(* Basic printing functions used in definition of the systems *)
+
+let int64_reg_name = function
+ | RAX -> "%rax" | RBX -> "%rbx" | RCX -> "%rcx" | RDX -> "%rdx"
+ | RSI -> "%rsi" | RDI -> "%rdi" | RBP -> "%rbp" | RSP -> "%rsp"
+ | R8 -> "%r8" | R9 -> "%r9" | R10 -> "%r10" | R11 -> "%r11"
+ | R12 -> "%r12" | R13 -> "%r13" | R14 -> "%r14" | R15 -> "%r15"
+
+let int32_reg_name = function
+ | RAX -> "%eax" | RBX -> "%ebx" | RCX -> "%ecx" | RDX -> "%edx"
+ | RSI -> "%esi" | RDI -> "%edi" | RBP -> "%ebp" | RSP -> "%esp"
+ | R8 -> "%r8d" | R9 -> "%r9d" | R10 -> "%r10d" | R11 -> "%r11d"
+ | R12 -> "%r12d" | R13 -> "%r13d" | R14 -> "%r14d" | R15 -> "%r15d"
+
+let int8_reg_name = function
+ | RAX -> "%al" | RBX -> "%bl" | RCX -> "%cl" | RDX -> "%dl"
+ | RSI -> "%sil" | RDI -> "%dil" | RBP -> "%bpl" | RSP -> "%spl"
+ | R8 -> "%r8b" | R9 -> "%r9b" | R10 -> "%r10b" | R11 -> "%r11b"
+ | R12 -> "%r12b" | R13 -> "%r13b" | R14 -> "%r14b" | R15 -> "%r15b"
+
+let int16_reg_name = function
+ | RAX -> "%ax" | RBX -> "%bx" | RCX -> "%cx" | RDX -> "%dx"
+ | RSI -> "%si" | RDI -> "%di" | RBP -> "%bp" | RSP -> "%sp"
+ | R8 -> "%r8w" | R9 -> "%r9w" | R10 -> "%r10w" | R11 -> "%r11w"
+ | R12 -> "%r12w" | R13 -> "%r13w" | R14 -> "%r14w" | R15 -> "%r15w"
+
+let float_reg_name = function
+ | XMM0 -> "%xmm0" | XMM1 -> "%xmm1" | XMM2 -> "%xmm2" | XMM3 -> "%xmm3"
+ | XMM4 -> "%xmm4" | XMM5 -> "%xmm5" | XMM6 -> "%xmm6" | XMM7 -> "%xmm7"
+ | XMM8 -> "%xmm8" | XMM9 -> "%xmm9" | XMM10 -> "%xmm10" | XMM11 -> "%xmm11"
+ | XMM12 -> "%xmm12" | XMM13 -> "%xmm13" | XMM14 -> "%xmm14" | XMM15 -> "%xmm15"
+
+let ireg8 oc r = output_string oc (int8_reg_name r)
+let ireg16 oc r = output_string oc (int16_reg_name r)
+let ireg32 oc r = output_string oc (int32_reg_name r)
+let ireg64 oc r = output_string oc (int64_reg_name r)
+let ireg = if Archi.ptr64 then ireg64 else ireg32
+let freg oc r = output_string oc (float_reg_name r)
+
+let preg oc = function
+ | IR r -> ireg oc r
+ | FR r -> freg oc r
+ | _ -> assert false
+
+let z oc n = output_string oc (Z.to_string n)
+
+(* 32/64 bit dependencies *)
+
+let data_pointer = if Archi.ptr64 then ".quad" else ".long"
+
+(* The comment deliminiter *)
+let comment = "#"
+
+(* System dependend printer functions *)
+module type SYSTEM =
+ sig
+ val raw_symbol: out_channel -> string -> unit
+ val symbol: out_channel -> P.t -> unit
+ val label: out_channel -> int -> unit
+ val name_of_section: section_name -> string
+ val stack_alignment: int
+ val print_align: out_channel -> int -> unit
+ val print_mov_rs: out_channel -> ireg -> ident -> unit
+ val print_fun_info: out_channel -> P.t -> unit
+ val print_var_info: out_channel -> P.t -> unit
+ val print_epilogue: out_channel -> unit
+ val print_comm_decl: out_channel -> P.t -> Z.t -> int -> unit
+ val print_lcomm_decl: out_channel -> P.t -> Z.t -> int -> unit
+ end
+
+(* Printer functions for ELF *)
+module ELF_System : SYSTEM =
+ struct
+
+ let raw_symbol oc s =
+ fprintf oc "%s" s
+
+ let symbol = elf_symbol
+
+ let label = elf_label
+
+ let name_of_section = function
+ | Section_text -> ".text"
+ | Section_data i | Section_small_data i ->
+ if i then ".data" else "COMM"
+ | Section_const i | Section_small_const i ->
+ if i then ".section .rodata" else "COMM"
+ | Section_string -> ".section .rodata"
+ | Section_literal -> ".section .rodata.cst8,\"aM\",@progbits,8"
+ | Section_jumptable -> ".text"
+ | Section_user(s, wr, ex) ->
+ sprintf ".section \"%s\",\"a%s%s\",@progbits"
+ s (if wr then "w" else "") (if ex then "x" else "")
+ | Section_debug_info _ -> ".section .debug_info,\"\",@progbits"
+ | Section_debug_loc -> ".section .debug_loc,\"\",@progbits"
+ | Section_debug_line _ -> ".section .debug_line,\"\",@progbits"
+ | Section_debug_abbrev -> ".section .debug_abbrev,\"\",@progbits"
+ | Section_debug_ranges -> ".section .debug_ranges,\"\",@progbits"
+ | Section_debug_str -> ".section .debug_str,\"MS\",@progbits,1"
+
+ let stack_alignment = 16
+
+ let print_align oc n =
+ fprintf oc " .align %d\n" n
+
+ let print_mov_rs oc rd id =
+ if Archi.ptr64
+ then fprintf oc " movq %a@GOTPCREL(%%rip), %a\n" symbol id ireg64 rd
+ else fprintf oc " movl $%a, %a\n" symbol id ireg32 rd
+
+ let print_fun_info = elf_print_fun_info
+
+ let print_var_info = elf_print_var_info
+
+ let print_epilogue _ = ()
+
+ let print_comm_decl oc name sz al =
+ fprintf oc " .comm %a, %s, %d\n" symbol name (Z.to_string sz) al
+
+ let print_lcomm_decl oc name sz al =
+ fprintf oc " .local %a\n" symbol name;
+ print_comm_decl oc name sz al
+
+ end
+
+(* Printer functions for MacOS *)
+module MacOS_System : SYSTEM =
+ struct
+
+ let raw_symbol oc s =
+ fprintf oc "_%s" s
+
+ let symbol oc symb =
+ raw_symbol oc (extern_atom symb)
+
+ let label oc lbl =
+ fprintf oc "L%d" lbl
+
+ let name_of_section = function
+ | Section_text -> ".text"
+ | Section_data i | Section_small_data i ->
+ if i then ".data" else "COMM"
+ | Section_const i | Section_small_const i ->
+ if i then ".const" else "COMM"
+ | Section_string -> ".const"
+ | Section_literal -> ".literal8"
+ | Section_jumptable -> ".const"
+ | Section_user(s, wr, ex) ->
+ sprintf ".section \"%s\", %s, %s"
+ (if wr then "__DATA" else "__TEXT") s
+ (if ex then "regular, pure_instructions" else "regular")
+ | Section_debug_info _ -> ".section __DWARF,__debug_info,regular,debug"
+ | Section_debug_loc -> ".section __DWARF,__debug_loc,regular,debug"
+ | Section_debug_line _ -> ".section __DWARF,__debug_line,regular,debug"
+ | Section_debug_str -> ".section __DWARF,__debug_str,regular,debug"
+ | Section_debug_ranges -> ".section __DWARF,__debug_ranges,regular,debug"
+ | Section_debug_abbrev -> ".section __DWARF,__debug_abbrev,regular,debug"
+
+
+ let stack_alignment = 16 (* mandatory *)
+
+ (* Base-2 log of a Caml integer *)
+ let rec log2 n =
+ assert (n > 0);
+ if n = 1 then 0 else 1 + log2 (n lsr 1)
+
+ let print_align oc n =
+ fprintf oc " .align %d\n" (log2 n)
+
+ let indirect_symbols : StringSet.t ref = ref StringSet.empty
+
+ let print_mov_rs oc rd id =
+ if Archi.ptr64 then begin
+ fprintf oc " movq %a@GOTPCREL(%%rip), %a\n" symbol id ireg64 rd
+ end else begin
+ let id = extern_atom id in
+ indirect_symbols := StringSet.add id !indirect_symbols;
+ fprintf oc " movl L%a$non_lazy_ptr, %a\n" raw_symbol id ireg rd
+ end
+
+ let print_fun_info _ _ = ()
+
+ let print_var_info _ _ = ()
+
+ let print_epilogue oc =
+ if not Archi.ptr64 then begin
+ fprintf oc " .section __IMPORT,__pointers,non_lazy_symbol_pointers\n";
+ StringSet.iter
+ (fun s ->
+ fprintf oc "L%a$non_lazy_ptr:\n" raw_symbol s;
+ fprintf oc " .indirect_symbol %a\n" raw_symbol s;
+ fprintf oc " .long 0\n")
+ !indirect_symbols;
+ indirect_symbols := StringSet.empty
+ end
+
+ let print_comm_decl oc name sz al =
+ fprintf oc " .comm %a, %s, %d\n"
+ symbol name (Z.to_string sz) (log2 al)
+
+ let print_lcomm_decl oc name sz al =
+ fprintf oc " .lcomm %a, %s, %d\n"
+ symbol name (Z.to_string sz) (log2 al)
+
+ end
+
+
+module Target(System: SYSTEM):TARGET =
+ struct
+ open System
+ let symbol = symbol
+
+(* Basic printing functions *)
+
+ let symbol_offset oc (symb, ofs) =
+ symbol oc symb;
+ let ofs = Z.to_int64 ofs in
+ if ofs <> 0L then fprintf oc " + %Ld" ofs
+
+ let addressing_gen ireg oc (Addrmode(base, shift, cst)) =
+ begin match cst with
+ | Coq_inl n ->
+ fprintf oc "%s" (Z.to_string n)
+ | Coq_inr(id, ofs) ->
+ if Archi.ptr64 then begin
+ (* RIP-relative addressing *)
+ let ofs' = Z.to_int64 ofs in
+ if ofs' = 0L
+ then fprintf oc "%a(%%rip)" symbol id
+ else fprintf oc "(%a + %Ld)(%%rip)" symbol id ofs'
+ end else begin
+ (* Absolute addressing *)
+ let ofs' = Z.to_int32 ofs in
+ if ofs' = 0l
+ then fprintf oc "%a" symbol id
+ else fprintf oc "(%a + %ld)" symbol id ofs'
+ end
+ end;
+ begin match base, shift with
+ | None, None -> ()
+ | Some r1, None -> fprintf oc "(%a)" ireg r1
+ | None, Some(r2,sc) -> fprintf oc "(,%a,%a)" ireg r2 z sc
+ | Some r1, Some(r2,sc) -> fprintf oc "(%a,%a,%a)" ireg r1 ireg r2 z sc
+ end
+
+ let addressing32 = addressing_gen ireg32
+ let addressing64 = addressing_gen ireg64
+ let addressing = addressing_gen ireg
+
+ let name_of_condition = function
+ | Cond_e -> "e" | Cond_ne -> "ne"
+ | Cond_b -> "b" | Cond_be -> "be" | Cond_ae -> "ae" | Cond_a -> "a"
+ | Cond_l -> "l" | Cond_le -> "le" | Cond_ge -> "ge" | Cond_g -> "g"
+ | Cond_p -> "p" | Cond_np -> "np"
+
+ let name_of_neg_condition = function
+ | Cond_e -> "ne" | Cond_ne -> "e"
+ | Cond_b -> "ae" | Cond_be -> "a" | Cond_ae -> "b" | Cond_a -> "be"
+ | Cond_l -> "ge" | Cond_le -> "g" | Cond_ge -> "l" | Cond_g -> "le"
+ | Cond_p -> "np" | Cond_np -> "p"
+
+
+(* Names of sections *)
+
+ let section oc sec =
+ fprintf oc " %s\n" (name_of_section sec)
+
+(* For "abs" and "neg" FP operations *)
+
+ let need_masks = ref false
+
+(* Emit .file / .loc debugging directives *)
+
+ let print_file_line oc file line =
+ print_file_line oc comment file line
+
+(* In 64-bit mode use RIP-relative addressing to designate labels *)
+
+ let rip_rel =
+ if Archi.ptr64 then "(%rip)" else ""
+
+(* Large 64-bit immediates (bigger than a 32-bit signed integer) are
+ not supported by the processor. Turn them into memory operands. *)
+
+ let intconst64 oc n =
+ let n1 = camlint64_of_coqint n in
+ let n2 = Int64.to_int32 n1 in
+ if n1 = Int64.of_int32 n2 then
+ (* fit in a 32-bit signed integer, can use as immediate *)
+ fprintf oc "$%ld" n2
+ else begin
+ (* put the constant in memory and use a PC-relative memory operand *)
+ let lbl = new_label() in
+ float64_literals := (lbl, n1) :: !float64_literals;
+ fprintf oc "%a(%%rip)" label lbl
+ end
+
+
+
+(* Printing of instructions *)
+
+(* Reminder on AT&T syntax: op source, dest *)
+
+ let print_instruction oc = function
+ (* Moves *)
+ | Pmov_rr(rd, r1) ->
+ if Archi.ptr64
+ then fprintf oc " movq %a, %a\n" ireg64 r1 ireg64 rd
+ else fprintf oc " movl %a, %a\n" ireg32 r1 ireg32 rd
+ | Pmovl_ri(rd, n) ->
+ fprintf oc " movl $%ld, %a\n" (camlint_of_coqint n) ireg32 rd
+ | Pmovq_ri(rd, n) ->
+ let n1 = camlint64_of_coqint n in
+ let n2 = Int64.to_int32 n1 in
+ if n1 = Int64.of_int32 n2 then
+ fprintf oc " movq $%ld, %a\n" n2 ireg64 rd
+ else
+ fprintf oc " movabsq $%Ld, %a\n" n1 ireg64 rd
+ | Pmov_rs(rd, id) ->
+ print_mov_rs oc rd id
+ | Pmovl_rm(rd, a) ->
+ fprintf oc " movl %a, %a\n" addressing a ireg32 rd
+ | Pmovq_rm(rd, a) ->
+ fprintf oc " movq %a, %a\n" addressing a ireg64 rd
+ | Pmov_rm_a(rd, a) ->
+ if Archi.ptr64
+ then fprintf oc " movq %a, %a\n" addressing a ireg64 rd
+ else fprintf oc " movl %a, %a\n" addressing a ireg32 rd
+ | Pmovl_mr(a, r1) ->
+ fprintf oc " movl %a, %a\n" ireg32 r1 addressing a
+ | Pmovq_mr(a, r1) ->
+ fprintf oc " movq %a, %a\n" ireg64 r1 addressing a
+ | Pmov_mr_a(a, r1) ->
+ if Archi.ptr64
+ then fprintf oc " movq %a, %a\n" ireg64 r1 addressing a
+ else fprintf oc " movl %a, %a\n" ireg32 r1 addressing a
+ | Pmovsd_ff(rd, r1) ->
+ fprintf oc " movapd %a, %a\n" freg r1 freg rd
+ | Pmovsd_fi(rd, n) ->
+ let b = camlint64_of_coqint (Floats.Float.to_bits n) in
+ let lbl = new_label() in
+ fprintf oc " movsd %a%s, %a %s %.18g\n"
+ label lbl rip_rel
+ freg rd comment (camlfloat_of_coqfloat n);
+ float64_literals := (lbl, b) :: !float64_literals
+ | Pmovsd_fm(rd, a) | Pmovsd_fm_a(rd, a) ->
+ fprintf oc " movsd %a, %a\n" addressing a freg rd
+ | Pmovsd_mf(a, r1) | Pmovsd_mf_a(a, r1) ->
+ fprintf oc " movsd %a, %a\n" freg r1 addressing a
+ | Pmovss_fi(rd, n) ->
+ let b = camlint_of_coqint (Floats.Float32.to_bits n) in
+ let lbl = new_label() in
+ fprintf oc " movss %a%s, %a %s %.18g\n"
+ label lbl rip_rel
+ freg rd comment (camlfloat_of_coqfloat32 n);
+ float32_literals := (lbl, b) :: !float32_literals
+ | Pmovss_fm(rd, a) ->
+ fprintf oc " movss %a, %a\n" addressing a freg rd
+ | Pmovss_mf(a, r1) ->
+ fprintf oc " movss %a, %a\n" freg r1 addressing a
+ | Pfldl_m(a) ->
+ fprintf oc " fldl %a\n" addressing a
+ | Pfstpl_m(a) ->
+ fprintf oc " fstpl %a\n" addressing a
+ | Pflds_m(a) ->
+ fprintf oc " flds %a\n" addressing a
+ | Pfstps_m(a) ->
+ fprintf oc " fstps %a\n" addressing a
+ (* Moves with conversion *)
+ | Pmovb_mr(a, r1) ->
+ fprintf oc " movb %a, %a\n" ireg8 r1 addressing a
+ | Pmovw_mr(a, r1) ->
+ fprintf oc " movw %a, %a\n" ireg16 r1 addressing a
+ | Pmovzb_rr(rd, r1) ->
+ fprintf oc " movzbl %a, %a\n" ireg8 r1 ireg32 rd
+ | Pmovzb_rm(rd, a) ->
+ fprintf oc " movzbl %a, %a\n" addressing a ireg32 rd
+ | Pmovsb_rr(rd, r1) ->
+ fprintf oc " movsbl %a, %a\n" ireg8 r1 ireg32 rd
+ | Pmovsb_rm(rd, a) ->
+ fprintf oc " movsbl %a, %a\n" addressing a ireg32 rd
+ | Pmovzw_rr(rd, r1) ->
+ fprintf oc " movzwl %a, %a\n" ireg16 r1 ireg32 rd
+ | Pmovzw_rm(rd, a) ->
+ fprintf oc " movzwl %a, %a\n" addressing a ireg32 rd
+ | Pmovsw_rr(rd, r1) ->
+ fprintf oc " movswl %a, %a\n" ireg16 r1 ireg32 rd
+ | Pmovsw_rm(rd, a) ->
+ fprintf oc " movswl %a, %a\n" addressing a ireg32 rd
+ | Pmovzl_rr(rd, r1) ->
+ fprintf oc " movl %a, %a\n" ireg32 r1 ireg32 rd
+ (* movl sets the high 32 bits of the destination to zero *)
+ | Pmovsl_rr(rd, r1) ->
+ fprintf oc " movslq %a, %a\n" ireg32 r1 ireg64 rd
+ | Pmovls_rr(rd) ->
+ () (* nothing to do *)
+ | Pcvtsd2ss_ff(rd, r1) ->
+ fprintf oc " cvtsd2ss %a, %a\n" freg r1 freg rd
+ | Pcvtss2sd_ff(rd, r1) ->
+ fprintf oc " cvtss2sd %a, %a\n" freg r1 freg rd
+ | Pcvttsd2si_rf(rd, r1) ->
+ fprintf oc " cvttsd2si %a, %a\n" freg r1 ireg32 rd
+ | Pcvtsi2sd_fr(rd, r1) ->
+ fprintf oc " cvtsi2sd %a, %a\n" ireg32 r1 freg rd
+ | Pcvttss2si_rf(rd, r1) ->
+ fprintf oc " cvttss2si %a, %a\n" freg r1 ireg32 rd
+ | Pcvtsi2ss_fr(rd, r1) ->
+ fprintf oc " cvtsi2ss %a, %a\n" ireg32 r1 freg rd
+ | Pcvttsd2sl_rf(rd, r1) ->
+ fprintf oc " cvttsd2si %a, %a\n" freg r1 ireg64 rd
+ | Pcvtsl2sd_fr(rd, r1) ->
+ fprintf oc " cvtsi2sdq %a, %a\n" ireg64 r1 freg rd
+ | Pcvttss2sl_rf(rd, r1) ->
+ fprintf oc " cvttss2si %a, %a\n" freg r1 ireg64 rd
+ | Pcvtsl2ss_fr(rd, r1) ->
+ fprintf oc " cvtsi2ssq %a, %a\n" ireg64 r1 freg rd
+ (* Arithmetic and logical operations over integers *)
+ | Pleal(rd, a) ->
+ fprintf oc " leal %a, %a\n" addressing32 a ireg32 rd
+ | Pleaq(rd, a) ->
+ fprintf oc " leaq %a, %a\n" addressing64 a ireg64 rd
+ | Pnegl(rd) ->
+ fprintf oc " negl %a\n" ireg32 rd
+ | Pnegq(rd) ->
+ fprintf oc " negq %a\n" ireg64 rd
+ | Paddl_ri (res,n) ->
+ fprintf oc " addl $%ld, %a\n" (camlint_of_coqint n) ireg32 res
+ | Paddq_ri (res,n) ->
+ fprintf oc " addq %a, %a\n" intconst64 n ireg64 res
+ | Psubl_rr(rd, r1) ->
+ fprintf oc " subl %a, %a\n" ireg32 r1 ireg32 rd
+ | Psubq_rr(rd, r1) ->
+ fprintf oc " subq %a, %a\n" ireg64 r1 ireg64 rd
+ | Pimull_rr(rd, r1) ->
+ fprintf oc " imull %a, %a\n" ireg32 r1 ireg32 rd
+ | Pimulq_rr(rd, r1) ->
+ fprintf oc " imulq %a, %a\n" ireg64 r1 ireg64 rd
+ | Pimull_ri(rd, n) ->
+ fprintf oc " imull $%a, %a\n" coqint n ireg32 rd
+ | Pimulq_ri(rd, n) ->
+ fprintf oc " imulq %a, %a\n" intconst64 n ireg64 rd
+ | Pimull_r(r1) ->
+ fprintf oc " imull %a\n" ireg32 r1
+ | Pimulq_r(r1) ->
+ fprintf oc " imulq %a\n" ireg64 r1
+ | Pmull_r(r1) ->
+ fprintf oc " mull %a\n" ireg32 r1
+ | Pmulq_r(r1) ->
+ fprintf oc " mulq %a\n" ireg64 r1
+ | Pcltd ->
+ fprintf oc " cltd\n"
+ | Pcqto ->
+ fprintf oc " cqto\n";
+ | Pdivl(r1) ->
+ fprintf oc " divl %a\n" ireg32 r1
+ | Pdivq(r1) ->
+ fprintf oc " divq %a\n" ireg64 r1
+ | Pidivl(r1) ->
+ fprintf oc " idivl %a\n" ireg32 r1
+ | Pidivq(r1) ->
+ fprintf oc " idivq %a\n" ireg64 r1
+ | Pandl_rr(rd, r1) ->
+ fprintf oc " andl %a, %a\n" ireg32 r1 ireg32 rd
+ | Pandq_rr(rd, r1) ->
+ fprintf oc " andq %a, %a\n" ireg64 r1 ireg64 rd
+ | Pandl_ri(rd, n) ->
+ fprintf oc " andl $%a, %a\n" coqint n ireg32 rd
+ | Pandq_ri(rd, n) ->
+ fprintf oc " andq %a, %a\n" intconst64 n ireg64 rd
+ | Porl_rr(rd, r1) ->
+ fprintf oc " orl %a, %a\n" ireg32 r1 ireg32 rd
+ | Porq_rr(rd, r1) ->
+ fprintf oc " orq %a, %a\n" ireg64 r1 ireg64 rd
+ | Porl_ri(rd, n) ->
+ fprintf oc " orl $%a, %a\n" coqint n ireg32 rd
+ | Porq_ri(rd, n) ->
+ fprintf oc " orq %a, %a\n" intconst64 n ireg64 rd
+ | Pxorl_r(rd) ->
+ fprintf oc " xorl %a, %a\n" ireg32 rd ireg32 rd
+ | Pxorq_r(rd) ->
+ fprintf oc " xorq %a, %a\n" ireg64 rd ireg64 rd
+ | Pxorl_rr(rd, r1) ->
+ fprintf oc " xorl %a, %a\n" ireg32 r1 ireg32 rd
+ | Pxorq_rr(rd, r1) ->
+ fprintf oc " xorq %a, %a\n" ireg64 r1 ireg64 rd
+ | Pxorl_ri(rd, n) ->
+ fprintf oc " xorl $%a, %a\n" coqint n ireg32 rd
+ | Pxorq_ri(rd, n) ->
+ fprintf oc " xorq %a, %a\n" intconst64 n ireg64 rd
+ | Pnotl(rd) ->
+ fprintf oc " notl %a\n" ireg32 rd
+ | Pnotq(rd) ->
+ fprintf oc " notq %a\n" ireg64 rd
+ | Psall_rcl(rd) ->
+ fprintf oc " sall %%cl, %a\n" ireg32 rd
+ | Psalq_rcl(rd) ->
+ fprintf oc " salq %%cl, %a\n" ireg64 rd
+ | Psall_ri(rd, n) ->
+ fprintf oc " sall $%a, %a\n" coqint n ireg32 rd
+ | Psalq_ri(rd, n) ->
+ fprintf oc " salq $%a, %a\n" coqint n ireg64 rd
+ | Pshrl_rcl(rd) ->
+ fprintf oc " shrl %%cl, %a\n" ireg32 rd
+ | Pshrq_rcl(rd) ->
+ fprintf oc " shrq %%cl, %a\n" ireg64 rd
+ | Pshrl_ri(rd, n) ->
+ fprintf oc " shrl $%a, %a\n" coqint n ireg32 rd
+ | Pshrq_ri(rd, n) ->
+ fprintf oc " shrq $%a, %a\n" coqint n ireg64 rd
+ | Psarl_rcl(rd) ->
+ fprintf oc " sarl %%cl, %a\n" ireg32 rd
+ | Psarq_rcl(rd) ->
+ fprintf oc " sarq %%cl, %a\n" ireg64 rd
+ | Psarl_ri(rd, n) ->
+ fprintf oc " sarl $%a, %a\n" coqint n ireg32 rd
+ | Psarq_ri(rd, n) ->
+ fprintf oc " sarq $%a, %a\n" coqint n ireg64 rd
+ | Pshld_ri(rd, r1, n) ->
+ fprintf oc " shldl $%a, %a, %a\n" coqint n ireg32 r1 ireg32 rd
+ | Prorl_ri(rd, n) ->
+ fprintf oc " rorl $%a, %a\n" coqint n ireg32 rd
+ | Prorq_ri(rd, n) ->
+ fprintf oc " rorq $%a, %a\n" coqint n ireg64 rd
+ | Pcmpl_rr(r1, r2) ->
+ fprintf oc " cmpl %a, %a\n" ireg32 r2 ireg32 r1
+ | Pcmpq_rr(r1, r2) ->
+ fprintf oc " cmpq %a, %a\n" ireg64 r2 ireg64 r1
+ | Pcmpl_ri(r1, n) ->
+ fprintf oc " cmpl $%a, %a\n" coqint n ireg32 r1
+ | Pcmpq_ri(r1, n) ->
+ fprintf oc " cmpq %a, %a\n" intconst64 n ireg64 r1
+ | Ptestl_rr(r1, r2) ->
+ fprintf oc " testl %a, %a\n" ireg32 r2 ireg32 r1
+ | Ptestq_rr(r1, r2) ->
+ fprintf oc " testq %a, %a\n" ireg64 r2 ireg64 r1
+ | Ptestl_ri(r1, n) ->
+ fprintf oc " testl $%a, %a\n" coqint n ireg32 r1
+ | Ptestq_ri(r1, n) ->
+ fprintf oc " testl %a, %a\n" intconst64 n ireg64 r1
+ | Pcmov(c, rd, r1) ->
+ fprintf oc " cmov%s %a, %a\n" (name_of_condition c) ireg r1 ireg rd
+ | Psetcc(c, rd) ->
+ fprintf oc " set%s %a\n" (name_of_condition c) ireg8 rd;
+ fprintf oc " movzbl %a, %a\n" ireg8 rd ireg32 rd
+ (* Arithmetic operations over floats *)
+ | Paddd_ff(rd, r1) ->
+ fprintf oc " addsd %a, %a\n" freg r1 freg rd
+ | Psubd_ff(rd, r1) ->
+ fprintf oc " subsd %a, %a\n" freg r1 freg rd
+ | Pmuld_ff(rd, r1) ->
+ fprintf oc " mulsd %a, %a\n" freg r1 freg rd
+ | Pdivd_ff(rd, r1) ->
+ fprintf oc " divsd %a, %a\n" freg r1 freg rd
+ | Pnegd (rd) ->
+ need_masks := true;
+ fprintf oc " xorpd %a%s, %a\n"
+ raw_symbol "__negd_mask" rip_rel freg rd
+ | Pabsd (rd) ->
+ need_masks := true;
+ fprintf oc " andpd %a%s, %a\n"
+ raw_symbol "__absd_mask" rip_rel freg rd
+ | Pcomisd_ff(r1, r2) ->
+ fprintf oc " comisd %a, %a\n" freg r2 freg r1
+ | Pxorpd_f (rd) ->
+ fprintf oc " xorpd %a, %a\n" freg rd freg rd
+ | Padds_ff(rd, r1) ->
+ fprintf oc " addss %a, %a\n" freg r1 freg rd
+ | Psubs_ff(rd, r1) ->
+ fprintf oc " subss %a, %a\n" freg r1 freg rd
+ | Pmuls_ff(rd, r1) ->
+ fprintf oc " mulss %a, %a\n" freg r1 freg rd
+ | Pdivs_ff(rd, r1) ->
+ fprintf oc " divss %a, %a\n" freg r1 freg rd
+ | Pnegs (rd) ->
+ need_masks := true;
+ fprintf oc " xorpd %a%s, %a\n"
+ raw_symbol "__negs_mask" rip_rel freg rd
+ | Pabss (rd) ->
+ need_masks := true;
+ fprintf oc " andpd %a%s, %a\n"
+ raw_symbol "__abss_mask" rip_rel freg rd
+ | Pcomiss_ff(r1, r2) ->
+ fprintf oc " comiss %a, %a\n" freg r2 freg r1
+ | Pxorps_f (rd) ->
+ fprintf oc " xorpd %a, %a\n" freg rd freg rd
+ (* Branches and calls *)
+ | Pjmp_l(l) ->
+ fprintf oc " jmp %a\n" label (transl_label l)
+ | Pjmp_s(f, sg) ->
+ fprintf oc " jmp %a\n" symbol f
+ | Pjmp_r(r, sg) ->
+ fprintf oc " jmp *%a\n" ireg r
+ | Pjcc(c, l) ->
+ let l = transl_label l in
+ fprintf oc " j%s %a\n" (name_of_condition c) label l
+ | Pjcc2(c1, c2, l) ->
+ let l = transl_label l in
+ let l' = new_label() in
+ fprintf oc " j%s %a\n" (name_of_neg_condition c1) label l';
+ fprintf oc " j%s %a\n" (name_of_condition c2) label l;
+ fprintf oc "%a:\n" label l'
+ | Pjmptbl(r, tbl) ->
+ let l = new_label() in
+ jumptables := (l, tbl) :: !jumptables;
+ if Archi.ptr64 then begin
+ let (tmp1, tmp2) =
+ if r = RAX then (RDX, RAX) else (RAX, RDX) in
+ fprintf oc " leaq %a(%%rip), %a\n" label l ireg tmp1;
+ fprintf oc " movslq (%a, %a, 4), %a\n" ireg tmp1 ireg r ireg tmp2;
+ fprintf oc " addq %a, %a\n" ireg tmp2 ireg tmp1;
+ fprintf oc " jmp *%a\n" ireg tmp1
+ end else begin
+ fprintf oc " jmp *%a(, %a, 4)\n" label l ireg r
+ end
+ | Pcall_s(f, sg) ->
+ fprintf oc " call %a\n" symbol f;
+ if (not Archi.ptr64) && sg.sig_cc.cc_structret then
+ fprintf oc " pushl %%eax\n"
+ | Pcall_r(r, sg) ->
+ fprintf oc " call *%a\n" ireg r;
+ if (not Archi.ptr64) && sg.sig_cc.cc_structret then
+ fprintf oc " pushl %%eax\n"
+ | Pret ->
+ if (not Archi.ptr64)
+ && (!current_function_sig).sig_cc.cc_structret then begin
+ fprintf oc " movl 0(%%esp), %%eax\n";
+ fprintf oc " ret $4\n"
+ end else begin
+ fprintf oc " ret\n"
+ end
+ (* Instructions produced by Asmexpand *)
+ | Padcl_ri (res,n) ->
+ fprintf oc " adcl $%ld, %a\n" (camlint_of_coqint n) ireg32 res;
+ | Padcl_rr (res,a1) ->
+ fprintf oc " adcl %a, %a\n" ireg32 a1 ireg32 res;
+ | Paddl_rr (res,a1) ->
+ fprintf oc " addl %a, %a\n" ireg32 a1 ireg32 res;
+ | Paddl_mi (addr,n) ->
+ fprintf oc " addl $%ld, %a\n" (camlint_of_coqint n) addressing addr
+ | Pbsfl (res,a1) ->
+ fprintf oc " bsfl %a, %a\n" ireg32 a1 ireg32 res
+ | Pbsfq (res,a1) ->
+ fprintf oc " bsfq %a, %a\n" ireg64 a1 ireg64 res
+ | Pbsrl (res,a1) ->
+ fprintf oc " bsrl %a, %a\n" ireg32 a1 ireg32 res
+ | Pbsrq (res,a1) ->
+ fprintf oc " bsrq %a, %a\n" ireg64 a1 ireg64 res
+ | Pbswap64 res ->
+ fprintf oc " bswap %a\n" ireg64 res
+ | Pbswap32 res ->
+ fprintf oc " bswap %a\n" ireg32 res
+ | Pbswap16 res ->
+ fprintf oc " rolw $8, %a\n" ireg16 res
+ | Pcfi_adjust sz ->
+ cfi_adjust oc (camlint_of_coqint sz)
+ | Pfmadd132 (res,a1,a2) ->
+ fprintf oc " vfmadd132sd %a, %a, %a\n" freg a1 freg a2 freg res
+ | Pfmadd213 (res,a1,a2) ->
+ fprintf oc " vfmadd213sd %a, %a, %a\n" freg a1 freg a2 freg res
+ | Pfmadd231 (res,a1,a2) ->
+ fprintf oc " vfmadd231sd %a, %a, %a\n" freg a1 freg a2 freg res
+ | Pfmsub132 (res,a1,a2) ->
+ fprintf oc " vfmsub132sd %a, %a, %a\n" freg a1 freg a2 freg res
+ | Pfmsub213 (res,a1,a2) ->
+ fprintf oc " vfmsub213sd %a, %a, %a\n" freg a1 freg a2 freg res
+ | Pfmsub231 (res,a1,a2) ->
+ fprintf oc " vfmsub231sd %a, %a, %a\n" freg a1 freg a2 freg res
+ | Pfnmadd132 (res,a1,a2) ->
+ fprintf oc " vfnmadd132sd %a, %a, %a\n" freg a1 freg a2 freg res
+ | Pfnmadd213 (res,a1,a2) ->
+ fprintf oc " vfnmadd213sd %a, %a, %a\n" freg a1 freg a2 freg res
+ | Pfnmadd231 (res,a1,a2) ->
+ fprintf oc " vfnmadd231sd %a, %a, %a\n" freg a1 freg a2 freg res
+ | Pfnmsub132 (res,a1,a2) ->
+ fprintf oc " vfnmsub132sd %a, %a, %a\n" freg a1 freg a2 freg res
+ | Pfnmsub213 (res,a1,a2) ->
+ fprintf oc " vfnmsub213sd %a, %a, %a\n" freg a1 freg a2 freg res
+ | Pfnmsub231 (res,a1,a2) ->
+ fprintf oc " vfnmsub231sd %a, %a, %a\n" freg a1 freg a2 freg res
+ | Pmaxsd (res,a1) ->
+ fprintf oc " maxsd %a, %a\n" freg a1 freg res
+ | Pminsd (res,a1) ->
+ fprintf oc " minsd %a, %a\n" freg a1 freg res
+ | Pmovb_rm (rd,a) ->
+ fprintf oc " movb %a, %a\n" addressing a ireg8 rd
+ | Pmovsq_mr(a, rs) ->
+ fprintf oc " movq %a, %a\n" freg rs addressing a
+ | Pmovsq_rm(rd, a) ->
+ fprintf oc " movq %a, %a\n" addressing a freg rd
+ | Pmovsb ->
+ fprintf oc " movsb\n";
+ | Pmovsw ->
+ fprintf oc " movsw\n";
+ | Pmovw_rm (rd, a) ->
+ fprintf oc " movw %a, %a\n" addressing a ireg16 rd
+ | Prep_movsl ->
+ fprintf oc " rep movsl\n"
+ | Psbbl_rr (res,a1) ->
+ fprintf oc " sbbl %a, %a\n" ireg32 a1 ireg32 res
+ | Psqrtsd (res,a1) ->
+ fprintf oc " sqrtsd %a, %a\n" freg a1 freg res
+ | Psubl_ri (res,n) ->
+ fprintf oc " subl $%ld, %a\n" (camlint_of_coqint n) ireg32 res;
+ | Psubq_ri (res,n) ->
+ fprintf oc " subq %a, %a\n" intconst64 n ireg64 res;
+ (* Pseudo-instructions *)
+ | Plabel(l) ->
+ fprintf oc "%a:\n" label (transl_label l)
+ | Pallocframe(sz, ofs_ra, ofs_link)
+ | Pfreeframe(sz, ofs_ra, ofs_link) ->
+ assert false
+ | Pbuiltin(ef, args, res) ->
+ begin match ef with
+ | EF_annot(txt, targs) ->
+ fprintf oc "%s annotation: " comment;
+ print_annot_text preg "%esp" oc (camlstring_of_coqstring txt) args
+ | EF_debug(kind, txt, targs) ->
+ print_debug_info comment print_file_line preg "%esp" oc
+ (P.to_int kind) (extern_atom txt) args
+ | EF_inline_asm(txt, sg, clob) ->
+ fprintf oc "%s begin inline assembly\n\t" comment;
+ print_inline_asm preg oc (camlstring_of_coqstring txt) sg args res;
+ fprintf oc "%s end inline assembly\n" comment
+ | _ ->
+ assert false
+ end
+
+ let print_literal64 oc (lbl, n) =
+ fprintf oc "%a: .quad 0x%Lx\n" label lbl n
+ let print_literal32 oc (lbl, n) =
+ fprintf oc "%a: .long 0x%lx\n" label lbl n
+
+ let print_jumptable oc jmptbl =
+ let print_jumptable (lbl, tbl) =
+ let print_entry l =
+ if Archi.ptr64 then
+ fprintf oc " .long %a - %a\n" label (transl_label l) label lbl
+ else
+ fprintf oc " .long %a\n" label (transl_label l)
+ in
+ fprintf oc "%a:" label lbl;
+ List.iter print_entry tbl
+ in
+ if !jumptables <> [] then begin
+ section oc jmptbl;
+ print_align oc 4;
+ List.iter print_jumptable !jumptables;
+ jumptables := []
+ end
+
+ 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_int64 n ->
+ fprintf oc " .quad %Ld\n" (camlint64_of_coqint n)
+ | Init_float32 n ->
+ fprintf oc " .long %ld %s %.18g\n"
+ (camlint_of_coqint (Floats.Float32.to_bits n))
+ comment (camlfloat_of_coqfloat32 n)
+ | Init_float64 n ->
+ fprintf oc " .quad %Ld %s %.18g\n"
+ (camlint64_of_coqint (Floats.Float.to_bits n))
+ comment (camlfloat_of_coqfloat n)
+ | Init_space n ->
+ if Z.gt n Z.zero then
+ fprintf oc " .space %a\n" z n
+ | Init_addrof(symb, ofs) ->
+ fprintf oc " %s %a\n" data_pointer symbol_offset (symb, ofs)
+
+ let print_align = print_align
+
+ let print_comm_symb oc sz name align =
+ if C2C.atom_is_static name
+ then System.print_lcomm_decl oc name sz align
+ else System.print_comm_decl oc name sz align
+
+ let name_of_section = name_of_section
+
+ let emit_constants oc lit =
+ if !float64_literals <> [] || !float32_literals <> [] then begin
+ section oc lit;
+ print_align oc 8;
+ List.iter (print_literal64 oc) !float64_literals;
+ float64_literals := [];
+ List.iter (print_literal32 oc) !float32_literals;
+ float32_literals := []
+ end
+
+ let cfi_startproc = cfi_startproc
+ let cfi_endproc = cfi_endproc
+
+ let print_instructions oc fn =
+ current_function_sig := fn.fn_sig;
+ List.iter (print_instruction oc) fn.fn_code
+
+ let print_optional_fun_info _ = ()
+
+ let get_section_names name =
+ match C2C.atom_sections name with
+ | [t;l;j] -> (t, l, j)
+ | _ -> (Section_text, Section_literal, Section_jumptable)
+
+ let reset_constants = reset_constants
+
+ let print_fun_info = print_fun_info
+
+ let print_var_info = print_var_info
+
+ let print_prologue oc =
+ need_masks := false;
+ if !Clflags.option_g then begin
+ section oc Section_text;
+ if Configuration.system <> "bsd" then cfi_section oc
+ end
+
+ let print_epilogue oc =
+ if !need_masks then begin
+ section oc (Section_const true);
+ (* not Section_literal because not 8-bytes *)
+ print_align oc 16;
+ fprintf oc "%a: .quad 0x8000000000000000, 0\n"
+ raw_symbol "__negd_mask";
+ fprintf oc "%a: .quad 0x7FFFFFFFFFFFFFFF, 0xFFFFFFFFFFFFFFFF\n"
+ raw_symbol "__absd_mask";
+ fprintf oc "%a: .long 0x80000000, 0, 0, 0\n"
+ raw_symbol "__negs_mask";
+ fprintf oc "%a: .long 0x7FFFFFFF, 0xFFFFFFFF, 0xFFFFFFFF, 0xFFFFFFFF\n"
+ raw_symbol "__abss_mask"
+ end;
+ System.print_epilogue oc;
+ if !Clflags.option_g then begin
+ Debug.compute_gnu_file_enum (fun f -> ignore (print_file oc f));
+ section oc Section_text;
+ end
+
+ let comment = comment
+
+ let default_falignment = 16
+
+ let label = label
+
+ let new_label = new_label
+
+end
+
+let sel_target () =
+ let module S = (val (match Configuration.system with
+ | "macosx" -> (module MacOS_System:SYSTEM)
+ | "linux"
+ | "bsd" -> (module ELF_System:SYSTEM)
+ | _ -> invalid_arg ("System " ^ Configuration.system ^ " not supported") ):SYSTEM) in
+ (module Target(S):TARGET)
diff --git a/x86/ValueAOp.v b/x86/ValueAOp.v
new file mode 100644
index 00000000..1021a9c8
--- /dev/null
+++ b/x86/ValueAOp.v
@@ -0,0 +1,264 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris *)
+(* *)
+(* 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 Compopts.
+Require Import AST Integers Floats Values Memory Globalenvs.
+Require Import Op RTL ValueDomain.
+
+(** Value analysis for x86_64 operators *)
+
+Definition eval_static_condition (cond: condition) (vl: list aval): abool :=
+ match cond, vl with
+ | Ccomp c, v1 :: v2 :: nil => cmp_bool c v1 v2
+ | Ccompu c, v1 :: v2 :: nil => cmpu_bool c v1 v2
+ | Ccompimm c n, v1 :: nil => cmp_bool c v1 (I n)
+ | Ccompuimm c n, v1 :: nil => cmpu_bool c v1 (I n)
+ | Ccompl c, v1 :: v2 :: nil => cmpl_bool c v1 v2
+ | Ccomplu c, v1 :: v2 :: nil => cmplu_bool c v1 v2
+ | Ccomplimm c n, v1 :: nil => cmpl_bool c v1 (L n)
+ | Ccompluimm c n, v1 :: nil => cmplu_bool c v1 (L n)
+ | Ccompf c, v1 :: v2 :: nil => cmpf_bool c v1 v2
+ | Cnotcompf c, v1 :: v2 :: nil => cnot (cmpf_bool c v1 v2)
+ | Ccompfs c, v1 :: v2 :: nil => cmpfs_bool c v1 v2
+ | Cnotcompfs c, v1 :: v2 :: nil => cnot (cmpfs_bool c v1 v2)
+ | Cmaskzero n, v1 :: nil => maskzero v1 n
+ | Cmasknotzero n, v1 :: nil => cnot (maskzero v1 n)
+ | _, _ => Bnone
+ end.
+
+Definition eval_static_addressing_32 (addr: addressing) (vl: list aval): aval :=
+ match addr, vl with
+ | Aindexed n, v1::nil => add v1 (I (Int.repr n))
+ | Aindexed2 n, v1::v2::nil => add (add v1 v2) (I (Int.repr n))
+ | Ascaled sc ofs, v1::nil => add (mul v1 (I (Int.repr sc))) (I (Int.repr ofs))
+ | Aindexed2scaled sc ofs, v1::v2::nil => add v1 (add (mul v2 (I (Int.repr sc))) (I (Int.repr ofs)))
+ | Aglobal s ofs, nil => Ptr (Gl s ofs)
+ | Abased s ofs, v1::nil => add (Ptr (Gl s ofs)) v1
+ | Abasedscaled sc s ofs, v1::nil => add (Ptr (Gl s ofs)) (mul v1 (I (Int.repr sc)))
+ | Ainstack ofs, nil => Ptr(Stk ofs)
+ | _, _ => Vbot
+ end.
+
+Definition eval_static_addressing_64 (addr: addressing) (vl: list aval): aval :=
+ match addr, vl with
+ | Aindexed n, v1::nil => addl v1 (L (Int64.repr n))
+ | Aindexed2 n, v1::v2::nil => addl (addl v1 v2) (L (Int64.repr n))
+ | Ascaled sc ofs, v1::nil => addl (mull v1 (L (Int64.repr sc))) (L (Int64.repr ofs))
+ | Aindexed2scaled sc ofs, v1::v2::nil => addl v1 (addl (mull v2 (L (Int64.repr sc))) (L (Int64.repr ofs)))
+ | Aglobal s ofs, nil => Ptr (Gl s ofs)
+ | Abased s ofs, v1::nil => addl (Ptr (Gl s ofs)) v1
+ | Abasedscaled sc s ofs, v1::nil => addl (Ptr (Gl s ofs)) (mull v1 (L (Int64.repr sc)))
+ | Ainstack ofs, nil => Ptr(Stk ofs)
+ | _, _ => Vbot
+ end.
+
+Definition eval_static_addressing (addr: addressing) (vl: list aval): aval :=
+ if Archi.ptr64
+ then eval_static_addressing_64 addr vl
+ else eval_static_addressing_32 addr vl.
+
+Definition eval_static_operation (op: operation) (vl: list aval): aval :=
+ match op, vl with
+ | Omove, v1::nil => v1
+ | Ointconst n, nil => I n
+ | Olongconst n, nil => L n
+ | Ofloatconst n, nil => if propagate_float_constants tt then F n else ntop
+ | Osingleconst n, nil => if propagate_float_constants tt then FS n else ntop
+ | Oindirectsymbol id, nil => Ifptr (Gl id Ptrofs.zero)
+ | Ocast8signed, v1 :: nil => sign_ext 8 v1
+ | Ocast8unsigned, v1 :: nil => zero_ext 8 v1
+ | Ocast16signed, v1 :: nil => sign_ext 16 v1
+ | Ocast16unsigned, v1 :: nil => zero_ext 16 v1
+ | Oneg, v1::nil => neg v1
+ | Osub, v1::v2::nil => sub v1 v2
+ | Omul, v1::v2::nil => mul v1 v2
+ | Omulimm n, v1::nil => mul v1 (I n)
+ | Omulhs, v1::v2::nil => mulhs v1 v2
+ | Omulhu, v1::v2::nil => mulhu v1 v2
+ | Odiv, v1::v2::nil => divs v1 v2
+ | Odivu, v1::v2::nil => divu v1 v2
+ | Omod, v1::v2::nil => mods v1 v2
+ | Omodu, v1::v2::nil => modu v1 v2
+ | Oand, v1::v2::nil => and v1 v2
+ | Oandimm n, v1::nil => and v1 (I n)
+ | Oor, v1::v2::nil => or v1 v2
+ | Oorimm n, v1::nil => or v1 (I n)
+ | Oxor, v1::v2::nil => xor v1 v2
+ | Oxorimm n, v1::nil => xor v1 (I n)
+ | Onot, v1::nil => notint v1
+ | Oshl, v1::v2::nil => shl v1 v2
+ | Oshlimm n, v1::nil => shl v1 (I n)
+ | Oshr, v1::v2::nil => shr v1 v2
+ | Oshrimm n, v1::nil => shr v1 (I n)
+ | Oshrximm n, v1::nil => shrx v1 (I n)
+ | Oshru, v1::v2::nil => shru v1 v2
+ | Oshruimm n, v1::nil => shru v1 (I n)
+ | Ororimm n, v1::nil => ror v1 (I n)
+ | Oshldimm n, v1::v2::nil => or (shl v1 (I n)) (shru v2 (I (Int.sub Int.iwordsize n)))
+ | Olea addr, _ => eval_static_addressing_32 addr vl
+ | Omakelong, v1::v2::nil => longofwords v1 v2
+ | Olowlong, v1::nil => loword v1
+ | Ohighlong, v1::nil => hiword v1
+ | Ocast32signed, v1::nil => longofint v1
+ | Ocast32unsigned, v1::nil => longofintu v1
+ | Onegl, v1::nil => negl v1
+ | Oaddlimm n, v1::nil => addl v1 (L n)
+ | Osubl, v1::v2::nil => subl v1 v2
+ | Omull, v1::v2::nil => mull v1 v2
+ | Omullimm n, v1::nil => mull v1 (L n)
+ | Omullhs, v1::v2::nil => mullhs v1 v2
+ | Omullhu, v1::v2::nil => mullhu v1 v2
+ | Odivl, v1::v2::nil => divls v1 v2
+ | Odivlu, v1::v2::nil => divlu v1 v2
+ | Omodl, v1::v2::nil => modls v1 v2
+ | Omodlu, v1::v2::nil => modlu v1 v2
+ | Oandl, v1::v2::nil => andl v1 v2
+ | Oandlimm n, v1::nil => andl v1 (L n)
+ | Oorl, v1::v2::nil => orl v1 v2
+ | Oorlimm n, v1::nil => orl v1 (L n)
+ | Oxorl, v1::v2::nil => xorl v1 v2
+ | Oxorlimm n, v1::nil => xorl v1 (L n)
+ | Onotl, v1::nil => notl v1
+ | Oshll, v1::v2::nil => shll v1 v2
+ | Oshllimm n, v1::nil => shll v1 (I n)
+ | Oshrl, v1::v2::nil => shrl v1 v2
+ | Oshrlimm n, v1::nil => shrl v1 (I n)
+ | Oshrxlimm n, v1::nil => shrxl v1 (I n)
+ | Oshrlu, v1::v2::nil => shrlu v1 v2
+ | Oshrluimm n, v1::nil => shrlu v1 (I n)
+ | Ororlimm n, v1::nil => rorl v1 (I n)
+ | Oleal addr, _ => eval_static_addressing_64 addr vl
+ | Onegf, v1::nil => negf v1
+ | Oabsf, v1::nil => absf v1
+ | Oaddf, v1::v2::nil => addf v1 v2
+ | Osubf, v1::v2::nil => subf v1 v2
+ | Omulf, v1::v2::nil => mulf v1 v2
+ | Odivf, v1::v2::nil => divf v1 v2
+ | Onegfs, v1::nil => negfs v1
+ | Oabsfs, v1::nil => absfs v1
+ | Oaddfs, v1::v2::nil => addfs v1 v2
+ | Osubfs, v1::v2::nil => subfs v1 v2
+ | Omulfs, v1::v2::nil => mulfs v1 v2
+ | Odivfs, v1::v2::nil => divfs v1 v2
+ | Osingleoffloat, v1::nil => singleoffloat v1
+ | Ofloatofsingle, v1::nil => floatofsingle v1
+ | Ointoffloat, v1::nil => intoffloat v1
+ | Ofloatofint, v1::nil => floatofint v1
+ | Ointofsingle, v1::nil => intofsingle v1
+ | Osingleofint, v1::nil => singleofint v1
+ | Olongoffloat, v1::nil => longoffloat v1
+ | Ofloatoflong, v1::nil => floatoflong v1
+ | Olongofsingle, v1::nil => longofsingle v1
+ | Osingleoflong, v1::nil => singleoflong v1
+ | Ocmp c, _ => of_optbool (eval_static_condition c vl)
+ | _, _ => Vbot
+ end.
+
+Section SOUNDNESS.
+
+Variable bc: block_classification.
+Variable ge: genv.
+Hypothesis GENV: genv_match bc ge.
+Variable sp: block.
+Hypothesis STACK: bc sp = BCstack.
+
+Theorem eval_static_condition_sound:
+ forall cond vargs m aargs,
+ list_forall2 (vmatch bc) vargs aargs ->
+ cmatch (eval_condition cond vargs m) (eval_static_condition cond aargs).
+Proof.
+ intros until aargs; intros VM. inv VM.
+ destruct cond; auto with va.
+ inv H0.
+ destruct cond; simpl; eauto with va.
+ inv H2.
+ destruct cond; simpl; eauto with va.
+ destruct cond; auto with va.
+Qed.
+
+Lemma symbol_address_sound:
+ forall id ofs,
+ vmatch bc (Genv.symbol_address ge id ofs) (Ptr (Gl id ofs)).
+Proof.
+ intros; apply symbol_address_sound; apply GENV.
+Qed.
+
+Lemma symbol_address_sound_2:
+ forall id ofs,
+ vmatch bc (Genv.symbol_address ge id ofs) (Ifptr (Gl id ofs)).
+Proof.
+ intros. unfold Genv.symbol_address. destruct (Genv.find_symbol ge id) as [b|] eqn:F.
+ constructor. constructor. apply GENV; auto.
+ constructor.
+Qed.
+
+Hint Resolve symbol_address_sound symbol_address_sound_2: va.
+
+Ltac InvHyps :=
+ match goal with
+ | [H: None = Some _ |- _ ] => discriminate
+ | [H: Some _ = Some _ |- _] => inv H
+ | [H1: match ?vl with nil => _ | _ :: _ => _ end = Some _ ,
+ H2: list_forall2 _ ?vl _ |- _ ] => inv H2; InvHyps
+ | [H: (if Archi.ptr64 then _ else _) = Some _ |- _] => destruct Archi.ptr64 eqn:?; InvHyps
+ | _ => idtac
+ end.
+
+Theorem eval_static_addressing_32_sound:
+ forall addr vargs vres aargs,
+ eval_addressing32 ge (Vptr sp Ptrofs.zero) addr vargs = Some vres ->
+ list_forall2 (vmatch bc) vargs aargs ->
+ vmatch bc vres (eval_static_addressing_32 addr aargs).
+Proof.
+ unfold eval_addressing32, eval_static_addressing_32; intros;
+ destruct addr; InvHyps; eauto with va.
+ rewrite Ptrofs.add_zero_l; eauto with va.
+Qed.
+
+Theorem eval_static_addressing_64_sound:
+ forall addr vargs vres aargs,
+ eval_addressing64 ge (Vptr sp Ptrofs.zero) addr vargs = Some vres ->
+ list_forall2 (vmatch bc) vargs aargs ->
+ vmatch bc vres (eval_static_addressing_64 addr aargs).
+Proof.
+ unfold eval_addressing64, eval_static_addressing_64; intros;
+ destruct addr; InvHyps; eauto with va.
+ rewrite Ptrofs.add_zero_l; eauto with va.
+Qed.
+
+Theorem eval_static_addressing_sound:
+ forall addr vargs vres aargs,
+ eval_addressing ge (Vptr sp Ptrofs.zero) addr vargs = Some vres ->
+ list_forall2 (vmatch bc) vargs aargs ->
+ vmatch bc vres (eval_static_addressing addr aargs).
+Proof.
+ unfold eval_addressing, eval_static_addressing; intros.
+ destruct Archi.ptr64; eauto using eval_static_addressing_32_sound, eval_static_addressing_64_sound.
+Qed.
+
+Theorem eval_static_operation_sound:
+ forall op vargs m vres aargs,
+ eval_operation ge (Vptr sp Ptrofs.zero) op vargs m = Some vres ->
+ list_forall2 (vmatch bc) vargs aargs ->
+ vmatch bc vres (eval_static_operation op aargs).
+Proof.
+ unfold eval_operation, eval_static_operation; intros;
+ destruct op; InvHyps; eauto with va.
+ destruct (propagate_float_constants tt); constructor.
+ destruct (propagate_float_constants tt); constructor.
+ eapply eval_static_addressing_32_sound; eauto.
+ eapply eval_static_addressing_64_sound; eauto.
+ apply of_optbool_sound. eapply eval_static_condition_sound; eauto.
+Qed.
+
+End SOUNDNESS.
+
diff --git a/x86/extractionMachdep.v b/x86/extractionMachdep.v
new file mode 100644
index 00000000..14cb6447
--- /dev/null
+++ b/x86/extractionMachdep.v
@@ -0,0 +1,26 @@
+(* *********************************************************************)
+(* *)
+(* 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. *)
+(* *)
+(* *********************************************************************)
+
+(* Additional extraction directives specific to the x86-64 port *)
+
+Require SelectOp ConstpropOp.
+
+(* SelectOp *)
+
+Extract Constant SelectOp.symbol_is_external =>
+ "fun id -> Configuration.system = ""macosx"" && C2C.atom_is_extern id".
+
+(* ConstpropOp *)
+
+Extract Constant ConstpropOp.symbol_is_external =>
+ "fun id -> Configuration.system = ""macosx"" && C2C.atom_is_extern id".
+
generated by cgit (git 2.34.1) at 2024-06-02 18:24:46 +0000