diff options
| author | Yann Herklotz <git@yannherklotz.com> | 2020-09-28 19:29:14 +0100 |
|---|---|---|
| committer | Yann Herklotz <git@yannherklotz.com> | 2023-04-27 11:53:24 +0100 |
| commit | 81e3066c13050677c5bc44ddbd22bd7c98f0e3e3 (patch) | |
| tree | 6a62ab1b3a5ac429e9de8129a382c9677d1e3d68 | |
| parent | 6f98b3b5f730d66f1878941d780db7b4384fbf60 (diff) | |
| download | compcert-81e3066c13050677c5bc44ddbd22bd7c98f0e3e3.tar.gz compcert-81e3066c13050677c5bc44ddbd22bd7c98f0e3e3.zip | |
Add Verilog backend
33 files changed, 16929 insertions, 0 deletions
@@ -57,6 +57,9 @@ Supported targets: x86_64-bsd (x86 64 bits, BSD) x86_64-macos (x86 64 bits, MacOS X) x86_64-cygwin (x86 64 bits, Cygwin environment under Windows) + verilog-linux (x86 64 bits, Linux) + verilog-bsd (x86 64 bits, BSD) + verilog-macosx (x86 64 bits, MacOS X) rv32-linux (RISC-V 32 bits, Linux) rv64-linux (RISC-V 64 bits, Linux) aarch64-linux (AArch64, i.e. ARMv8 in 64-bit mode, Linux) @@ -188,6 +191,8 @@ case "$target" in arch="x86"; model="32sse2"; endianness="little"; bitsize=32;; x86_64-*|amd64-*) arch="x86"; model="64"; endianness="little"; bitsize=64;; + verilog-*) + arch="verilog"; model="32"; endianness="little"; bitsize=64;; powerpc-*|ppc-*) arch="powerpc"; model="ppc32"; endianness="big"; bitsize=32;; powerpc64-*|ppc64-*) @@ -383,6 +388,55 @@ if test "$arch" = "x86" -a "$bitsize" = "64"; then esac fi +if test "$arch" = "verilog" -a "$bitsize" = "64"; then + + case "$target" in + bsd) + abi="standard" + casm="${toolprefix}gcc" + casm_options="-m64 -c" + cc="${toolprefix}gcc -m64" + clinker="${toolprefix}gcc" + clinker_options="-m64" + cprepro="${toolprefix}gcc" + cprepro_options="-std=c99 -m64 -U__GNUC__ -E" + libmath="-lm" + system="bsd" + ;; + linux) + abi="standard" + casm="${toolprefix}gcc" + casm_options="-m64 -c" + cc="${toolprefix}gcc -m64" + clinker="${toolprefix}gcc" + clinker_options="-m64" + cprepro="${toolprefix}gcc" + cprepro_options="-std=c99 -m64 -U__GNUC__ -E" + libmath="-lm" + system="linux" + ;; + macosx) + # kernel major versions count upwards from 4 for OSX 10.0 to 15 for OSX 10.11 + kernel_major=`uname -r | cut -d "." -f 1` + + abi="macosx" + casm="${toolprefix}gcc" + casm_options="-arch x86_64 -c" + cc="${toolprefix}gcc -arch x86_64" + clinker="${toolprefix}gcc" + clinker_needs_no_pie=false + cprepro="${toolprefix}gcc" + cprepro_options="-std=c99 -arch x86_64 -U__GNUC__ -U__clang__ -U__BLOCKS__ '-D__attribute__(x)=' '-D__asm(x)=' '-D_Nullable=' '-D_Nonnull=' -E" + libmath="" + system="macosx" + ;; + *) + echo "Error: invalid eabi/system '$target' for architecture X86_64." 1>&2 + echo "$usage" 1>&2 + exit 2;; + esac +fi + # # RISC-V Target Configuration diff --git a/verilog/Archi.v b/verilog/Archi.v new file mode 100644 index 00000000..e59274e2 --- /dev/null +++ b/verilog/Archi.v @@ -0,0 +1,60 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* Jacques-Henri Jourdan, INRIA Paris *) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Architecture-dependent parameters for x86 in 32-bit mode *) + +From Flocq Require Import Binary Bits. +Require Import ZArith List. + +Definition ptr64 := false. + +Definition big_endian := false. + +Definition align_int64 := 4%Z. +Definition align_float64 := 4%Z. + +Definition splitlong := false. + +Definition default_nan_64 := (true, iter_nat 51 _ xO xH). +Definition default_nan_32 := (true, iter_nat 22 _ xO xH). + +(* Always choose the first NaN argument, if any *) + +Definition choose_nan_64 (l: list (bool * positive)) : bool * positive := + match l with nil => default_nan_64 | n :: _ => n end. + +Definition choose_nan_32 (l: list (bool * positive)) : bool * positive := + match l with nil => default_nan_32 | n :: _ => n end. + +Lemma choose_nan_64_idem: forall n, + choose_nan_64 (n :: n :: nil) = choose_nan_64 (n :: nil). +Proof. auto. Qed. + +Lemma choose_nan_32_idem: forall n, + choose_nan_32 (n :: n :: nil) = choose_nan_32 (n :: nil). +Proof. auto. Qed. + +Definition fma_order {A: Type} (x y z: A) := (x, y, z). + +Definition fma_invalid_mul_is_nan := false. + +Definition float_of_single_preserves_sNaN := false. + +Global Opaque ptr64 big_endian splitlong + default_nan_64 choose_nan_64 + default_nan_32 choose_nan_32 + fma_order fma_invalid_mul_is_nan + float_of_single_preserves_sNaN. diff --git a/verilog/Asm.v b/verilog/Asm.v new file mode 100644 index 00000000..58e28c40 --- /dev/null +++ b/verilog/Asm.v @@ -0,0 +1,1218 @@ +(* *********************************************************************) +(* *) +(* 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) + | Pnop + | 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) : asm. +Notation "a # b <- c" := (Pregmap.set b c a) (at level 1, b at next level) : asm. + +Open Scope asm. + +(** Undefining some registers *) + +Fixpoint undef_regs (l: list preg) (rs: regset) : regset := + match l with + | nil => rs + | r :: l' => undef_regs l' (rs#r <- Vundef) + end. + +(** Assigning a register pair *) + +Definition set_pair (p: rpair preg) (v: val) (rs: regset) : regset := + match p with + | One r => rs#r <- v + | Twolong rhi rlo => rs#rhi <- (Val.hiword v) #rlo <- (Val.loword v) + end. + +(** Assigning 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 and ordered +- 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 (Float.cmp Ceq x y || negb (Float.ordered x y))) + #CF <- (Val.of_bool (negb (Float.cmp Cge x y))) + #PF <- (Val.of_bool (negb (Float.ordered 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 (Float32.cmp Ceq x y || negb (Float32.ordered x y))) + #CF <- (Val.of_bool (negb (Float32.cmp Cge x y))) + #PF <- (Val.of_bool (negb (Float32.ordered 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 => + let v := + match eval_testcond c rs with + | Some b => if b then rs#r1 else rs#rd + | None => Vundef + end in + Next (nextinstr (rs#rd <- v)) m + | 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 _ _ + | Pnop + | 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. + +(** Undefine all registers except SP and callee-save registers *) + +Definition undef_caller_save_regs (rs: regset) : regset := + fun r => + if preg_eq r SP + || In_dec preg_eq r (List.map preg_of (List.filter is_callee_save all_mregs)) + then rs r + else Vundef. + +(** 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 (undef_caller_save_regs 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/verilog/AsmToJSON.ml b/verilog/AsmToJSON.ml new file mode 100644 index 00000000..59cc7d40 --- /dev/null +++ b/verilog/AsmToJSON.ml @@ -0,0 +1,23 @@ +(* *********************************************************************) +(* *) +(* 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 destination: string option ref = ref None + +let sdump_folder = ref "" + +let print_if prog sourcename = + () + +let pp_mnemonics pp = () diff --git a/verilog/AsmToJSON.mli b/verilog/AsmToJSON.mli new file mode 100644 index 00000000..52c055c4 --- /dev/null +++ b/verilog/AsmToJSON.mli @@ -0,0 +1,19 @@ +(* *********************************************************************) +(* *) +(* 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 pp_mnemonics: Format.formatter -> unit + +val print_if: (Asm.coq_function AST.fundef, 'a) AST.program -> string -> unit + +val destination: string option ref + +val sdump_folder : string ref diff --git a/verilog/Asmexpand.ml b/verilog/Asmexpand.ml new file mode 100644 index 00000000..caa9775a --- /dev/null +++ b/verilog/Asmexpand.ml @@ -0,0 +1,646 @@ +(* *********************************************************************) +(* *) +(* 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 kind txt targ args res = + emit (Pbuiltin (EF_annot(kind,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 + | BA_addptr(BA (IR r), BA_int n) -> linear_addr r (Integers.Int.signed n) + | BA_addptr(BA (IR r), BA_long n) -> linear_addr r (Integers.Int64.signed n) + | _ -> 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 (Conventions.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", [BA(IR a1)], BR(IR res) -> + emit (Pbsrl (res,a1)); + emit (Pxorl_ri(res,coqint_of_camlint 31l)) + | "__builtin_clzl", [BA(IR a1)], BR(IR res) -> + if not(Archi.ptr64) then begin + emit (Pbsrl (res,a1)); + emit (Pxorl_ri(res,coqint_of_camlint 31l)) + end else begin + emit (Pbsrq (res,a1)); + emit (Pxorl_ri(res,coqint_of_camlint 63l)) + end + | "__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", [BA(IR a1)], BR(IR res) -> + emit (Pbsfl (res,a1)) + | "__builtin_ctzl", [BA(IR a1)], BR(IR res) -> + if not(Archi.ptr64) then + emit (Pbsfl (res,a1)) + else + emit (Pbsfq (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_fsqrt" | "__builtin_sqrt"), [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 Pnop + (* 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 = Tvoid; 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(kind,txt, targ) -> + expand_annot_val kind 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; + expand id (int_reg_to_dwarf RSP) preg_to_dwarf 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/verilog/Asmgen.v b/verilog/Asmgen.v new file mode 100644 index 00000000..73e3263e --- /dev/null +++ b/verilog/Asmgen.v @@ -0,0 +1,788 @@ +(* *********************************************************************) +(* *) +(* 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. + +Local Open Scope string_scope. +Local Open Scope error_monad_scope. + +(** The code generation functions take advantage of several characteristics of the [Mach] code generated by earlier passes of the compiler: +- 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) => + if Op.offset_in_range n + then (a, None) + else (Addrmode base ofs (inl _ 0), Some (Int64.repr n)) + | Addrmode base ofs (inr (id, delta)) => + if Op.ptroffset_in_range delta || negb Archi.ptr64 + then (a, None) + else (Addrmode base ofs (inr _ (id, Ptrofs.zero)), Some (Ptrofs.to_int64 delta)) + 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. + +Definition negate_testcond (c: testcond) : testcond := + match c with + | Cond_e => Cond_ne | Cond_ne => Cond_e + | Cond_b => Cond_ae | Cond_be => Cond_a + | Cond_ae => Cond_b | Cond_a => Cond_be + | Cond_l => Cond_ge | Cond_le => Cond_g + | Cond_ge => Cond_l | Cond_g => Cond_le + | Cond_p => Cond_np | Cond_np => Cond_p + end. + +Definition mk_sel (cond: extcond) (rd r2: ireg) (k: code) := + match cond with + | Cond_base c => + OK (Pcmov (negate_testcond c) rd r2 :: k) + | Cond_and c1 c2 => + OK (Pcmov (negate_testcond c1) rd r2 :: + Pcmov (negate_testcond c2) rd r2 :: k) + | Cond_or c1 c2 => + Error (msg "Asmgen.mk_sel") (**r should never happen, see [SelectOp.select] *) + end. + +Definition transl_sel + (cond: condition) (args: list mreg) (rd r2: ireg) (k: code) : res code := + if ireg_eq rd r2 then + OK (Pmov_rr rd r2 :: k) (* must generate one instruction... *) + else + do k1 <- mk_sel (testcond_for_condition cond) rd r2 k; + transl_cond cond args k1. + +(** 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) + | Osel c ty, a1 :: a2 :: args => + assertion (mreg_eq a1 res); + do r <- ireg_of res; do r2 <- ireg_of a2; + transl_sel c args r r2 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/verilog/Asmgenproof.v b/verilog/Asmgenproof.v new file mode 100644 index 00000000..f1fd41e3 --- /dev/null +++ b/verilog/Asmgenproof.v @@ -0,0 +1,927 @@ +(* *********************************************************************) +(* *) +(* 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 mk_sel_label: + forall xc rd r2 k c, + mk_sel xc rd r2 k = OK c -> + tail_nolabel k c. +Proof. + unfold mk_sel; intros; destruct xc; inv H; 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. + unfold transl_sel in EQ2. destruct (ireg_eq x x0); monadInv EQ2. + TailNoLabel. + eapply tail_nolabel_trans. eapply transl_cond_label; eauto. eapply mk_sel_label; eauto. +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 B as [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 B as [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 Z.le_refl. apply Z.le_refl. + intros [m1' [C D]]. + exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto. + intros [m2' [F G]]. + 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. + apply agree_undef_caller_save_regs; 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/verilog/Asmgenproof1.v b/verilog/Asmgenproof1.v new file mode 100644 index 00000000..fd88954e --- /dev/null +++ b/verilog/Asmgenproof1.v @@ -0,0 +1,1540 @@ +(* *********************************************************************) +(* *) +(* 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. + +Local Open 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 (v' := if Int.lt x Int.zero then Vint x' else Vint x). + set (rs4 := nextinstr (rs3#RAX <- v')). + 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, v'. rewrite H, H0. destruct (Int.lt x Int.zero); simpl; auto. + auto. + apply exec_straight_one. auto. auto. + split. unfold rs5. Simplifs. unfold rs4. rewrite nextinstr_inv; auto with asmgen. + rewrite Pregmap.gss. unfold v'. rewrite A. reflexivity. + intros. unfold rs5. Simplifs. unfold rs4. Simplifs. + 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|[id delta]]]; simpl. +- destruct (offset_in_range n); auto; simpl. + rewrite ! Val.addl_assoc. apply f_equal. apply f_equal. simpl. rewrite Int64.add_zero_l; auto. +- destruct Archi.ptr64 eqn:SF; auto; simpl; + destruct (ptroffset_in_range delta); auto. simpl. + rewrite ! Val.addl_assoc. apply f_equal. apply f_equal. + rewrite <- Genv.shift_symbol_address_64 by auto. + f_equal. rewrite Ptrofs.add_zero_l, Ptrofs.of_int64_to_int64 by auto. 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 (Float.cmp Ceq n1 n2 || negb (Float.ordered n1 n2)) + /\ rs'#CF = Val.of_bool (negb (Float.cmp Cge n1 n2)) + /\ rs'#PF = Val.of_bool (negb (Float.ordered 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 (Float32.cmp Ceq n1 n2 || negb (Float32.ordered n1 n2)) + /\ rs'#CF = Val.of_bool (negb (Float32.cmp Cge n1 n2)) + /\ rs'#PF = Val.of_bool (negb (Float32.ordered 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 *) +Transparent Float.cmp Float.ordered. + unfold Float.ordered, Float.cmp; destruct (Float.compare n1 n2) as [[]|]; reflexivity. +- (* ne *) + unfold Float.ordered, Float.cmp; destruct (Float.compare n1 n2) as [[]|]; reflexivity. +- (* lt *) + rewrite <- (Float.cmp_swap Clt n2 n1). simpl. unfold Float.ordered. + destruct (Float.compare n2 n1) as [[]|]; reflexivity. +- (* le *) + rewrite <- (Float.cmp_swap Cge n1 n2). simpl. + destruct (Float.compare n1 n2) as [[]|]; auto. +- (* gt *) + unfold Float.ordered, Float.cmp; destruct (Float.compare n1 n2) as [[]|]; reflexivity. +- (* ge *) + destruct (Float.cmp Cge n1 n2); auto. +Opaque Float.cmp Float.ordered. +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 *) +Transparent Float.cmp Float.ordered. + unfold Float.ordered, Float.cmp; destruct (Float.compare n1 n2) as [[]|]; reflexivity. +- (* ne *) + unfold Float.ordered, Float.cmp; destruct (Float.compare n1 n2) as [[]|]; reflexivity. +- (* lt *) + rewrite <- (Float.cmp_swap Clt n2 n1). simpl. unfold Float.ordered. + destruct (Float.compare n2 n1) as [[]|]; reflexivity. +- (* le *) + rewrite <- (Float.cmp_swap Cge n1 n2). simpl. + destruct (Float.compare n1 n2) as [[]|]; auto. +- (* gt *) + unfold Float.ordered, Float.cmp; destruct (Float.compare n1 n2) as [[]|]; reflexivity. +- (* ge *) + destruct (Float.cmp Cge n1 n2); auto. +Opaque Float.cmp Float.ordered. +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 *) +Transparent Float32.cmp Float32.ordered. + unfold Float32.ordered, Float32.cmp; destruct (Float32.compare n1 n2) as [[]|]; reflexivity. +- (* ne *) + unfold Float32.ordered, Float32.cmp; destruct (Float32.compare n1 n2) as [[]|]; reflexivity. +- (* lt *) + rewrite <- (Float32.cmp_swap Clt n2 n1). simpl. unfold Float32.ordered. + destruct (Float32.compare n2 n1) as [[]|]; reflexivity. +- (* le *) + rewrite <- (Float32.cmp_swap Cge n1 n2). simpl. + destruct (Float32.compare n1 n2) as [[]|]; auto. +- (* gt *) + unfold Float32.ordered, Float32.cmp; destruct (Float32.compare n1 n2) as [[]|]; reflexivity. +- (* ge *) + destruct (Float32.cmp Cge n1 n2); auto. +Opaque Float32.cmp Float32.ordered. +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 *) +Transparent Float32.cmp Float32.ordered. + unfold Float32.ordered, Float32.cmp; destruct (Float32.compare n1 n2) as [[]|]; reflexivity. +- (* ne *) + unfold Float32.ordered, Float32.cmp; destruct (Float32.compare n1 n2) as [[]|]; reflexivity. +- (* lt *) + rewrite <- (Float32.cmp_swap Clt n2 n1). simpl. unfold Float32.ordered. + destruct (Float32.compare n2 n1) as [[]|]; reflexivity. +- (* le *) + rewrite <- (Float32.cmp_swap Cge n1 n2). simpl. + destruct (Float32.compare n1 n2) as [[]|]; auto. +- (* gt *) + unfold Float32.ordered, Float32.cmp; destruct (Float32.compare n1 n2) as [[]|]; reflexivity. +- (* ge *) + destruct (Float32.cmp Cge n1 n2); auto. +Opaque Float32.cmp Float32.ordered. +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 + /\ eval_extcond (testcond_for_condition (negate_condition cond)) rs' = Some (negb 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. split. + eapply testcond_for_signed_comparison_32_correct; eauto. + eapply testcond_for_signed_comparison_32_correct; eauto. + rewrite Val.negate_cmp_bool, Heqo; auto. + 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. split. + eapply testcond_for_unsigned_comparison_32_correct; eauto. + eapply testcond_for_unsigned_comparison_32_correct; eauto. + rewrite Val.negate_cmpu_bool, Heqo; auto. + 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. split. + eapply testcond_for_signed_comparison_32_correct; eauto. + eapply testcond_for_signed_comparison_32_correct; eauto. + rewrite Val.negate_cmp_bool; auto. + 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. split. + eapply testcond_for_signed_comparison_32_correct; eauto. + eapply testcond_for_signed_comparison_32_correct; eauto. + rewrite Val.negate_cmp_bool, Heqo; auto. + 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; split. + eapply testcond_for_unsigned_comparison_32_correct; eauto. + eapply testcond_for_unsigned_comparison_32_correct; eauto. + rewrite Val.negate_cmpu_bool, Heqo; auto. + 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. split. + eapply testcond_for_signed_comparison_64_correct; eauto. + eapply testcond_for_signed_comparison_64_correct; eauto. + rewrite Val.negate_cmpl_bool, Heqo; auto. + 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. split. + eapply testcond_for_unsigned_comparison_64_correct; eauto. + eapply testcond_for_unsigned_comparison_64_correct; eauto. + rewrite Val.negate_cmplu_bool, Heqo; auto. + 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. split. + eapply testcond_for_signed_comparison_64_correct; eauto. + eapply testcond_for_signed_comparison_64_correct; eauto. + rewrite Val.negate_cmpl_bool; auto. + 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. split. + eapply testcond_for_signed_comparison_64_correct; eauto. + eapply testcond_for_signed_comparison_64_correct; eauto. + rewrite Val.negate_cmpl_bool, Heqo; auto. + 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. split. + eapply testcond_for_unsigned_comparison_64_correct; eauto. + eapply testcond_for_unsigned_comparison_64_correct; eauto. + rewrite Val.negate_cmplu_bool, Heqo; auto. + 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. split. + apply testcond_for_float_comparison_correct. + apply testcond_for_neg_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. split. + apply testcond_for_neg_float_comparison_correct. + rewrite negb_involutive. apply testcond_for_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. split. + apply testcond_for_float32_comparison_correct. + apply testcond_for_neg_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. split. + apply testcond_for_neg_float32_comparison_correct. + rewrite negb_involutive. apply testcond_for_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. + +Definition negate_extcond (xc: extcond) : extcond := + match xc with + | Cond_base c => Cond_base (negate_testcond c) + | Cond_and c1 c2 => Cond_or (negate_testcond c1) (negate_testcond c2) + | Cond_or c1 c2 => Cond_and (negate_testcond c1) (negate_testcond c2) + end. + +Remark negate_testcond_for_condition: + forall cond, + negate_extcond (testcond_for_condition cond) = testcond_for_condition (negate_condition cond). +Proof. + intros. destruct cond; try destruct c; reflexivity. +Qed. + +Lemma mk_sel_correct: + forall xc ty rd r2 k c ob rs m, + mk_sel xc rd r2 k = OK c -> + rd <> r2 -> + match ob with + | Some b => eval_extcond xc rs = Some b /\ eval_extcond (negate_extcond xc) rs = Some (negb b) + | None => True + end -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ Val.lessdef (Val.select ob rs#rd rs#r2 ty) rs'#rd + /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs r. +Proof. + intros. destruct xc; monadInv H; simpl in H1. +- econstructor; split. + eapply exec_straight_one. reflexivity. reflexivity. + set (v := match eval_testcond (negate_testcond c0) rs with + | Some true => rs r2 + | Some false => rs rd + | None => Vundef + end). + split. rewrite nextinstr_inv, Pregmap.gss by eauto with asmgen. + destruct ob; simpl; auto. destruct H1 as [_ B]; unfold v; rewrite B. + destruct b; apply Val.lessdef_normalize. + intros; Simplifs. +- econstructor; split. + eapply exec_straight_two. + reflexivity. reflexivity. reflexivity. reflexivity. + set (v1 := match eval_testcond (negate_testcond c1) rs with + | Some true => rs r2 + | Some false => rs rd + | None => Vundef + end). + rewrite eval_testcond_nextinstr, eval_testcond_set_ireg. + set (v2 := match eval_testcond (negate_testcond c2) rs with + | Some true => nextinstr rs # rd <- v1 r2 + | Some false => nextinstr rs # rd <- v1 rd + | None => Vundef + end). + split. rewrite nextinstr_inv, Pregmap.gss by eauto with asmgen. + destruct ob; simpl; auto. + destruct H1 as [_ B]. + destruct (eval_testcond (negate_testcond c1) rs) as [b1|]; try discriminate. + destruct (eval_testcond (negate_testcond c2) rs) as [b2|]; try discriminate. + inv B. apply negb_sym in H1. subst b. + replace v2 with (if b2 then rs#r2 else v1). + unfold v1. destruct b1, b2; apply Val.lessdef_normalize. + unfold v2. destruct b2; symmetry; Simplifs. + intros; Simplifs. +Qed. + +Lemma transl_sel_correct: + forall ty cond args rd r2 k c rs m, + transl_sel cond args rd r2 k = OK c -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ Val.lessdef (Val.select (eval_condition cond (map rs (map preg_of args)) m) rs#rd rs#r2 ty) rs'#rd + /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs r. +Proof. + unfold transl_sel; intros. destruct (ireg_eq rd r2); monadInv H. +- econstructor; split. + apply exec_straight_one; reflexivity. + split. rewrite nextinstr_inv, Pregmap.gss by auto with asmgen. + destruct eval_condition as [[]|]; simpl; auto using Val.lessdef_normalize. + intros; Simplifs. +- destruct (transl_cond_correct _ _ _ _ rs m EQ0) as (rs1 & A & B & C). + rewrite <- negate_testcond_for_condition in B. + destruct (mk_sel_correct _ ty _ _ _ _ _ rs1 m EQ n B) as (rs2 & D & E & F). + exists rs2; split. + eapply exec_straight_trans; eauto. + split. rewrite ! C in E by auto with asmgen. exact E. + intros. rewrite F; auto. +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 *; + let X := fresh "EQ" in generalize (ireg_of_eq _ _ H); intros X; + 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). + destruct Q as [Q _]. rewrite Q. auto. + simpl; auto. + intros. transitivity (rs2 r); auto. +(* selection *) + rewrite EQ1. exploit transl_sel_correct; eauto. intros (rs' & A & B & C). + exists rs'; split. eexact A. eauto. +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/verilog/Builtins1.v b/verilog/Builtins1.v new file mode 100644 index 00000000..f1d60961 --- /dev/null +++ b/verilog/Builtins1.v @@ -0,0 +1,54 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, Collège de France and Inria Paris *) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Platform-specific built-in functions *) + +Require Import String Coqlib. +Require Import AST Integers Floats Values. +Require Import Builtins0. + +Inductive platform_builtin : Type := + | BI_fmin + | BI_fmax. + +Local Open Scope string_scope. + +Definition platform_builtin_table : list (string * platform_builtin) := + ("__builtin_fmin", BI_fmin) + :: ("__builtin_fmax", BI_fmax) + :: nil. + +Definition platform_builtin_sig (b: platform_builtin) : signature := + match b with + | BI_fmin | BI_fmax => + mksignature (Tfloat :: Tfloat :: nil) Tfloat cc_default + end. + +Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (sig_res (platform_builtin_sig b)) := + match b with + | BI_fmin => + mkbuiltin_n2t Tfloat Tfloat Tfloat + (fun f1 f2 => match Float.compare f1 f2 with + | Some Eq | Some Lt => f1 + | Some Gt | None => f2 + end) + | BI_fmax => + mkbuiltin_n2t Tfloat Tfloat Tfloat + (fun f1 f2 => match Float.compare f1 f2 with + | Some Eq | Some Gt => f1 + | Some Lt | None => f2 + end) + end. + diff --git a/verilog/CBuiltins.ml b/verilog/CBuiltins.ml new file mode 100644 index 00000000..6820c089 --- /dev/null +++ b/verilog/CBuiltins.ml @@ -0,0 +1,68 @@ +(* *********************************************************************) +(* *) +(* 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 = { + builtin_typedefs = [ + "__builtin_va_list", va_list_type; + ]; + builtin_functions = [ + (* Float arithmetic *) + "__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); + ] +} + +(* Expand memory references inside extended asm statements. Used in C2C. *) + +let asm_mem_argument arg = Printf.sprintf "0(%s)" arg diff --git a/verilog/CombineOp.v b/verilog/CombineOp.v new file mode 100644 index 00000000..34c1c9cc --- /dev/null +++ b/verilog/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/verilog/CombineOpproof.v b/verilog/CombineOpproof.v new file mode 100644 index 00000000..69abbf61 --- /dev/null +++ b/verilog/CombineOpproof.v @@ -0,0 +1,180 @@ +(* *********************************************************************) +(* *) +(* 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 FunInd. +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/verilog/ConstpropOp.v b/verilog/ConstpropOp.v new file mode 100644 index 00000000..9b9c9711 --- /dev/null +++ b/verilog/ConstpropOp.v @@ -0,0 +1,899 @@ +(* *********************************************************************) +(* *) +(* 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 ValueAOp. + +(** * 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. *) + +(** Original definition: +<< +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. +>> +*) + +Inductive cond_strength_reduction_cases: forall (cond: condition) (args: list reg) (vl: list aval), Type := + | cond_strength_reduction_case1: forall c r1 r2 n1 v2, cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | cond_strength_reduction_case2: forall c r1 r2 v1 n2, cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | cond_strength_reduction_case3: forall c r1 r2 n1 v2, cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | cond_strength_reduction_case4: forall c r1 r2 v1 n2, cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | cond_strength_reduction_case5: forall c r1 r2 n1 v2, cond_strength_reduction_cases (Ccompl c) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) + | cond_strength_reduction_case6: forall c r1 r2 v1 n2, cond_strength_reduction_cases (Ccompl c) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | cond_strength_reduction_case7: forall c r1 r2 n1 v2, cond_strength_reduction_cases (Ccomplu c) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) + | cond_strength_reduction_case8: forall c r1 r2 v1 n2, cond_strength_reduction_cases (Ccomplu c) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | cond_strength_reduction_default: forall (cond: condition) (args: list reg) (vl: list aval), cond_strength_reduction_cases cond args vl. + +Definition cond_strength_reduction_match (cond: condition) (args: list reg) (vl: list aval) := + match cond as zz1, args as zz2, vl as zz3 return cond_strength_reduction_cases zz1 zz2 zz3 with + | Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil => cond_strength_reduction_case1 c r1 r2 n1 v2 + | Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil => cond_strength_reduction_case2 c r1 r2 v1 n2 + | Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil => cond_strength_reduction_case3 c r1 r2 n1 v2 + | Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil => cond_strength_reduction_case4 c r1 r2 v1 n2 + | Ccompl c, r1 :: r2 :: nil, L n1 :: v2 :: nil => cond_strength_reduction_case5 c r1 r2 n1 v2 + | Ccompl c, r1 :: r2 :: nil, v1 :: L n2 :: nil => cond_strength_reduction_case6 c r1 r2 v1 n2 + | Ccomplu c, r1 :: r2 :: nil, L n1 :: v2 :: nil => cond_strength_reduction_case7 c r1 r2 n1 v2 + | Ccomplu c, r1 :: r2 :: nil, v1 :: L n2 :: nil => cond_strength_reduction_case8 c r1 r2 v1 n2 + | cond, args, vl => cond_strength_reduction_default cond args vl + end. + +Definition cond_strength_reduction (cond: condition) (args: list reg) (vl: list aval) := + match cond_strength_reduction_match cond args vl with + | cond_strength_reduction_case1 c r1 r2 n1 v2 => (* Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + (Ccompimm (swap_comparison c) n1, r2 :: nil) + | cond_strength_reduction_case2 c r1 r2 v1 n2 => (* Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + (Ccompimm c n2, r1 :: nil) + | cond_strength_reduction_case3 c r1 r2 n1 v2 => (* Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + (Ccompuimm (swap_comparison c) n1, r2 :: nil) + | cond_strength_reduction_case4 c r1 r2 v1 n2 => (* Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + (Ccompuimm c n2, r1 :: nil) + | cond_strength_reduction_case5 c r1 r2 n1 v2 => (* Ccompl c, r1 :: r2 :: nil, L n1 :: v2 :: nil *) + (Ccomplimm (swap_comparison c) n1, r2 :: nil) + | cond_strength_reduction_case6 c r1 r2 v1 n2 => (* Ccompl c, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + (Ccomplimm c n2, r1 :: nil) + | cond_strength_reduction_case7 c r1 r2 n1 v2 => (* Ccomplu c, r1 :: r2 :: nil, L n1 :: v2 :: nil *) + (Ccompluimm (swap_comparison c) n1, r2 :: nil) + | cond_strength_reduction_case8 c r1 r2 v1 n2 => (* Ccomplu c, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + (Ccompluimm c n2, r1 :: nil) + | cond_strength_reduction_default cond args vl => + (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'). + +Definition make_cmp_imm_eq (c: condition) (args: list reg) (vl: list aval) + (n: int) (r1: reg) (v1: aval) := + 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. + +Definition make_cmp_imm_ne (c: condition) (args: list reg) (vl: list aval) + (n: int) (r1: reg) (v1: aval) := + 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. + +(** Original definition: +<< +Nondetfunction make_cmp (c: condition) (args: list reg) (vl: list aval) := + match c, args, vl with + | Ccompimm Ceq n, r1 :: nil, v1 :: nil => + make_cmp_imm_eq c args vl n r1 v1 + | Ccompimm Cne n, r1 :: nil, v1 :: nil => + make_cmp_imm_ne c args vl n r1 v1 + | Ccompuimm Ceq n, r1 :: nil, v1 :: nil => + make_cmp_imm_eq c args vl n r1 v1 + | Ccompuimm Cne n, r1 :: nil, v1 :: nil => + make_cmp_imm_ne c args vl n r1 v1 + | _, _, _ => + make_cmp_base c args vl + end. +>> +*) + +Inductive make_cmp_cases: forall (c: condition) (args: list reg) (vl: list aval), Type := + | make_cmp_case1: forall n r1 v1, make_cmp_cases (Ccompimm Ceq n) (r1 :: nil) (v1 :: nil) + | make_cmp_case2: forall n r1 v1, make_cmp_cases (Ccompimm Cne n) (r1 :: nil) (v1 :: nil) + | make_cmp_case3: forall n r1 v1, make_cmp_cases (Ccompuimm Ceq n) (r1 :: nil) (v1 :: nil) + | make_cmp_case4: forall n r1 v1, make_cmp_cases (Ccompuimm Cne n) (r1 :: nil) (v1 :: nil) + | make_cmp_default: forall (c: condition) (args: list reg) (vl: list aval), make_cmp_cases c args vl. + +Definition make_cmp_match (c: condition) (args: list reg) (vl: list aval) := + match c as zz1, args as zz2, vl as zz3 return make_cmp_cases zz1 zz2 zz3 with + | Ccompimm Ceq n, r1 :: nil, v1 :: nil => make_cmp_case1 n r1 v1 + | Ccompimm Cne n, r1 :: nil, v1 :: nil => make_cmp_case2 n r1 v1 + | Ccompuimm Ceq n, r1 :: nil, v1 :: nil => make_cmp_case3 n r1 v1 + | Ccompuimm Cne n, r1 :: nil, v1 :: nil => make_cmp_case4 n r1 v1 + | c, args, vl => make_cmp_default c args vl + end. + +Definition make_cmp (c: condition) (args: list reg) (vl: list aval) := + match make_cmp_match c args vl with + | make_cmp_case1 n r1 v1 => (* Ccompimm Ceq n, r1 :: nil, v1 :: nil *) + make_cmp_imm_eq c args vl n r1 v1 + | make_cmp_case2 n r1 v1 => (* Ccompimm Cne n, r1 :: nil, v1 :: nil *) + make_cmp_imm_ne c args vl n r1 v1 + | make_cmp_case3 n r1 v1 => (* Ccompuimm Ceq n, r1 :: nil, v1 :: nil *) + make_cmp_imm_eq c args vl n r1 v1 + | make_cmp_case4 n r1 v1 => (* Ccompuimm Cne n, r1 :: nil, v1 :: nil *) + make_cmp_imm_ne c args vl n r1 v1 + | make_cmp_default c args vl => + make_cmp_base c args vl + end. + + +Definition make_select (c: condition) (ty: typ) + (r1 r2: reg) (args: list reg) (vl: list aval) := + match resolve_branch (eval_static_condition c vl) with + | Some b => (Omove, (if b then r1 else r2) :: nil) + | None => + let (c', args') := cond_strength_reduction c args vl in + (Osel c' ty, r1 :: r2 :: args') + 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. +*) + +(** Original definition: +<< +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. +>> +*) + +Inductive addr_strength_reduction_32_generic_cases: forall (addr: addressing) (args: list reg) (vl: list aval), Type := + | addr_strength_reduction_32_generic_case1: forall ofs r1 r2 n1 v2, addr_strength_reduction_32_generic_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | addr_strength_reduction_32_generic_case2: forall ofs r1 r2 v1 n2, addr_strength_reduction_32_generic_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | addr_strength_reduction_32_generic_case3: forall sc ofs r1 r2 v1 n2, addr_strength_reduction_32_generic_cases (Aindexed2scaled sc ofs) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | addr_strength_reduction_32_generic_case4: forall sc ofs r1 r2 n1 v2, addr_strength_reduction_32_generic_cases (Aindexed2scaled sc ofs) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | addr_strength_reduction_32_generic_default: forall (addr: addressing) (args: list reg) (vl: list aval), addr_strength_reduction_32_generic_cases addr args vl. + +Definition addr_strength_reduction_32_generic_match (addr: addressing) (args: list reg) (vl: list aval) := + match addr as zz1, args as zz2, vl as zz3 return addr_strength_reduction_32_generic_cases zz1 zz2 zz3 with + | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: v2 :: nil => addr_strength_reduction_32_generic_case1 ofs r1 r2 n1 v2 + | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil => addr_strength_reduction_32_generic_case2 ofs r1 r2 v1 n2 + | Aindexed2scaled sc ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil => addr_strength_reduction_32_generic_case3 sc ofs r1 r2 v1 n2 + | Aindexed2scaled sc ofs, r1 :: r2 :: nil, I n1 :: v2 :: nil => addr_strength_reduction_32_generic_case4 sc ofs r1 r2 n1 v2 + | addr, args, vl => addr_strength_reduction_32_generic_default addr args vl + end. + +Definition addr_strength_reduction_32_generic (addr: addressing) (args: list reg) (vl: list aval) := + match addr_strength_reduction_32_generic_match addr args vl with + | addr_strength_reduction_32_generic_case1 ofs r1 r2 n1 v2 => (* Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + (Aindexed (Int.signed n1 + ofs), r2 :: nil) + | addr_strength_reduction_32_generic_case2 ofs r1 r2 v1 n2 => (* Aindexed2 ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + (Aindexed (Int.signed n2 + ofs), r1 :: nil) + | addr_strength_reduction_32_generic_case3 sc ofs r1 r2 v1 n2 => (* Aindexed2scaled sc ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + (Aindexed (Int.signed n2 * sc + ofs), r1 :: nil) + | addr_strength_reduction_32_generic_case4 sc ofs r1 r2 n1 v2 => (* Aindexed2scaled sc ofs, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + (Ascaled sc (Int.signed n1 + ofs), r2 :: nil) + | addr_strength_reduction_32_generic_default addr args vl => + (addr, args) + end. + + +(** Original definition: +<< +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. +>> +*) + +Inductive addr_strength_reduction_32_cases: forall (addr: addressing) (args: list reg) (vl: list aval), Type := + | addr_strength_reduction_32_case1: forall ofs r1 symb n, addr_strength_reduction_32_cases (Aindexed ofs) (r1 :: nil) (Ptr(Gl symb n) :: nil) + | addr_strength_reduction_32_case2: forall ofs r1 n, addr_strength_reduction_32_cases (Aindexed ofs) (r1 :: nil) (Ptr(Stk n) :: nil) + | addr_strength_reduction_32_case3: forall ofs r1 r2 symb n1 n2, addr_strength_reduction_32_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (Ptr(Gl symb n1) :: I n2 :: nil) + | addr_strength_reduction_32_case4: forall ofs r1 r2 n1 symb n2, addr_strength_reduction_32_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (I n1 :: Ptr(Gl symb n2) :: nil) + | addr_strength_reduction_32_case5: forall ofs r1 r2 n1 n2, addr_strength_reduction_32_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (Ptr(Stk n1) :: I n2 :: nil) + | addr_strength_reduction_32_case6: forall ofs r1 r2 n1 n2, addr_strength_reduction_32_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (I n1 :: Ptr(Stk n2) :: nil) + | addr_strength_reduction_32_case7: forall ofs r1 r2 symb n1 v2, addr_strength_reduction_32_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (Ptr(Gl symb n1) :: v2 :: nil) + | addr_strength_reduction_32_case8: forall ofs r1 r2 v1 symb n2, addr_strength_reduction_32_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (v1 :: Ptr(Gl symb n2) :: nil) + | addr_strength_reduction_32_case9: forall sc ofs r1 r2 symb n1 n2, addr_strength_reduction_32_cases (Aindexed2scaled sc ofs) (r1 :: r2 :: nil) (Ptr(Gl symb n1) :: I n2 :: nil) + | addr_strength_reduction_32_case10: forall sc ofs r1 r2 symb n1 v2, addr_strength_reduction_32_cases (Aindexed2scaled sc ofs) (r1 :: r2 :: nil) (Ptr(Gl symb n1) :: v2 :: nil) + | addr_strength_reduction_32_case11: forall id ofs r1 n1, addr_strength_reduction_32_cases (Abased id ofs) (r1 :: nil) (I n1 :: nil) + | addr_strength_reduction_32_case12: forall sc id ofs r1 n1, addr_strength_reduction_32_cases (Abasedscaled sc id ofs) (r1 :: nil) (I n1 :: nil) + | addr_strength_reduction_32_default: forall (addr: addressing) (args: list reg) (vl: list aval), addr_strength_reduction_32_cases addr args vl. + +Definition addr_strength_reduction_32_match (addr: addressing) (args: list reg) (vl: list aval) := + match addr as zz1, args as zz2, vl as zz3 return addr_strength_reduction_32_cases zz1 zz2 zz3 with + | Aindexed ofs, r1 :: nil, Ptr(Gl symb n) :: nil => addr_strength_reduction_32_case1 ofs r1 symb n + | Aindexed ofs, r1 :: nil, Ptr(Stk n) :: nil => addr_strength_reduction_32_case2 ofs r1 n + | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: I n2 :: nil => addr_strength_reduction_32_case3 ofs r1 r2 symb n1 n2 + | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: Ptr(Gl symb n2) :: nil => addr_strength_reduction_32_case4 ofs r1 r2 n1 symb n2 + | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Stk n1) :: I n2 :: nil => addr_strength_reduction_32_case5 ofs r1 r2 n1 n2 + | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: Ptr(Stk n2) :: nil => addr_strength_reduction_32_case6 ofs r1 r2 n1 n2 + | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: v2 :: nil => addr_strength_reduction_32_case7 ofs r1 r2 symb n1 v2 + | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: Ptr(Gl symb n2) :: nil => addr_strength_reduction_32_case8 ofs r1 r2 v1 symb n2 + | Aindexed2scaled sc ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: I n2 :: nil => addr_strength_reduction_32_case9 sc ofs r1 r2 symb n1 n2 + | Aindexed2scaled sc ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: v2 :: nil => addr_strength_reduction_32_case10 sc ofs r1 r2 symb n1 v2 + | Abased id ofs, r1 :: nil, I n1 :: nil => addr_strength_reduction_32_case11 id ofs r1 n1 + | Abasedscaled sc id ofs, r1 :: nil, I n1 :: nil => addr_strength_reduction_32_case12 sc id ofs r1 n1 + | addr, args, vl => addr_strength_reduction_32_default addr args vl + end. + +Definition 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_strength_reduction_32_match addr args vl with + | addr_strength_reduction_32_case1 ofs r1 symb n => (* Aindexed ofs, r1 :: nil, Ptr(Gl symb n) :: nil *) + (Aglobal symb (Ptrofs.add n (Ptrofs.repr ofs)), nil) + | addr_strength_reduction_32_case2 ofs r1 n => (* Aindexed ofs, r1 :: nil, Ptr(Stk n) :: nil *) + (Ainstack (Ptrofs.add n (Ptrofs.repr ofs)), nil) + | addr_strength_reduction_32_case3 ofs r1 r2 symb n1 n2 => (* 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) + | addr_strength_reduction_32_case4 ofs r1 r2 n1 symb n2 => (* 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) + | addr_strength_reduction_32_case5 ofs r1 r2 n1 n2 => (* 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) + | addr_strength_reduction_32_case6 ofs r1 r2 n1 n2 => (* 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) + | addr_strength_reduction_32_case7 ofs r1 r2 symb n1 v2 => (* Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: v2 :: nil *) + (Abased symb (Ptrofs.add n1 (Ptrofs.repr ofs)), r2 :: nil) + | addr_strength_reduction_32_case8 ofs r1 r2 v1 symb n2 => (* Aindexed2 ofs, r1 :: r2 :: nil, v1 :: Ptr(Gl symb n2) :: nil *) + (Abased symb (Ptrofs.add n2 (Ptrofs.repr ofs)), r1 :: nil) + | addr_strength_reduction_32_case9 sc ofs r1 r2 symb n1 n2 => (* 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) + | addr_strength_reduction_32_case10 sc ofs r1 r2 symb n1 v2 => (* Aindexed2scaled sc ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: v2 :: nil *) + (Abasedscaled sc symb (Ptrofs.add n1 (Ptrofs.repr ofs)), r2 :: nil) + | addr_strength_reduction_32_case11 id ofs r1 n1 => (* Abased id ofs, r1 :: nil, I n1 :: nil *) + (Aglobal id (Ptrofs.add ofs (Ptrofs.of_int n1)), nil) + | addr_strength_reduction_32_case12 sc id ofs r1 n1 => (* 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_default addr args vl => + addr_strength_reduction_32_generic addr args vl + end. + + +(** Original definition: +<< +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. +>> +*) + +Inductive addr_strength_reduction_64_generic_cases: forall (addr: addressing) (args: list reg) (vl: list aval), Type := + | addr_strength_reduction_64_generic_case1: forall ofs r1 r2 n1 v2, addr_strength_reduction_64_generic_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) + | addr_strength_reduction_64_generic_case2: forall ofs r1 r2 v1 n2, addr_strength_reduction_64_generic_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | addr_strength_reduction_64_generic_case3: forall sc ofs r1 r2 v1 n2, addr_strength_reduction_64_generic_cases (Aindexed2scaled sc ofs) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | addr_strength_reduction_64_generic_case4: forall sc ofs r1 r2 n1 v2, addr_strength_reduction_64_generic_cases (Aindexed2scaled sc ofs) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) + | addr_strength_reduction_64_generic_default: forall (addr: addressing) (args: list reg) (vl: list aval), addr_strength_reduction_64_generic_cases addr args vl. + +Definition addr_strength_reduction_64_generic_match (addr: addressing) (args: list reg) (vl: list aval) := + match addr as zz1, args as zz2, vl as zz3 return addr_strength_reduction_64_generic_cases zz1 zz2 zz3 with + | Aindexed2 ofs, r1 :: r2 :: nil, L n1 :: v2 :: nil => addr_strength_reduction_64_generic_case1 ofs r1 r2 n1 v2 + | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: L n2 :: nil => addr_strength_reduction_64_generic_case2 ofs r1 r2 v1 n2 + | Aindexed2scaled sc ofs, r1 :: r2 :: nil, v1 :: L n2 :: nil => addr_strength_reduction_64_generic_case3 sc ofs r1 r2 v1 n2 + | Aindexed2scaled sc ofs, r1 :: r2 :: nil, L n1 :: v2 :: nil => addr_strength_reduction_64_generic_case4 sc ofs r1 r2 n1 v2 + | addr, args, vl => addr_strength_reduction_64_generic_default addr args vl + end. + +Definition addr_strength_reduction_64_generic (addr: addressing) (args: list reg) (vl: list aval) := + match addr_strength_reduction_64_generic_match addr args vl with + | addr_strength_reduction_64_generic_case1 ofs r1 r2 n1 v2 => (* Aindexed2 ofs, r1 :: r2 :: nil, L n1 :: v2 :: nil *) + (Aindexed (Int64.signed n1 + ofs), r2 :: nil) + | addr_strength_reduction_64_generic_case2 ofs r1 r2 v1 n2 => (* Aindexed2 ofs, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + (Aindexed (Int64.signed n2 + ofs), r1 :: nil) + | addr_strength_reduction_64_generic_case3 sc ofs r1 r2 v1 n2 => (* Aindexed2scaled sc ofs, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + (Aindexed (Int64.signed n2 * sc + ofs), r1 :: nil) + | addr_strength_reduction_64_generic_case4 sc ofs r1 r2 n1 v2 => (* Aindexed2scaled sc ofs, r1 :: r2 :: nil, L n1 :: v2 :: nil *) + (Ascaled sc (Int64.signed n1 + ofs), r2 :: nil) + | addr_strength_reduction_64_generic_default addr args vl => + (addr, args) + end. + + +(** Original definition: +<< +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. +>> +*) + +Inductive addr_strength_reduction_64_cases: forall (addr: addressing) (args: list reg) (vl: list aval), Type := + | addr_strength_reduction_64_case1: forall ofs r1 symb n, addr_strength_reduction_64_cases (Aindexed ofs) (r1 :: nil) (Ptr(Gl symb n) :: nil) + | addr_strength_reduction_64_case2: forall ofs r1 n, addr_strength_reduction_64_cases (Aindexed ofs) (r1 :: nil) (Ptr(Stk n) :: nil) + | addr_strength_reduction_64_case3: forall ofs r1 r2 symb n1 n2, addr_strength_reduction_64_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (Ptr(Gl symb n1) :: L n2 :: nil) + | addr_strength_reduction_64_case4: forall ofs r1 r2 n1 symb n2, addr_strength_reduction_64_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (L n1 :: Ptr(Gl symb n2) :: nil) + | addr_strength_reduction_64_case5: forall ofs r1 r2 n1 n2, addr_strength_reduction_64_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (Ptr(Stk n1) :: L n2 :: nil) + | addr_strength_reduction_64_case6: forall ofs r1 r2 n1 n2, addr_strength_reduction_64_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (L n1 :: Ptr(Stk n2) :: nil) + | addr_strength_reduction_64_case7: forall sc ofs r1 r2 symb n1 n2, addr_strength_reduction_64_cases (Aindexed2scaled sc ofs) (r1 :: r2 :: nil) (Ptr(Gl symb n1) :: L n2 :: nil) + | addr_strength_reduction_64_default: forall (addr: addressing) (args: list reg) (vl: list aval), addr_strength_reduction_64_cases addr args vl. + +Definition addr_strength_reduction_64_match (addr: addressing) (args: list reg) (vl: list aval) := + match addr as zz1, args as zz2, vl as zz3 return addr_strength_reduction_64_cases zz1 zz2 zz3 with + | Aindexed ofs, r1 :: nil, Ptr(Gl symb n) :: nil => addr_strength_reduction_64_case1 ofs r1 symb n + | Aindexed ofs, r1 :: nil, Ptr(Stk n) :: nil => addr_strength_reduction_64_case2 ofs r1 n + | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: L n2 :: nil => addr_strength_reduction_64_case3 ofs r1 r2 symb n1 n2 + | Aindexed2 ofs, r1 :: r2 :: nil, L n1 :: Ptr(Gl symb n2) :: nil => addr_strength_reduction_64_case4 ofs r1 r2 n1 symb n2 + | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Stk n1) :: L n2 :: nil => addr_strength_reduction_64_case5 ofs r1 r2 n1 n2 + | Aindexed2 ofs, r1 :: r2 :: nil, L n1 :: Ptr(Stk n2) :: nil => addr_strength_reduction_64_case6 ofs r1 r2 n1 n2 + | Aindexed2scaled sc ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: L n2 :: nil => addr_strength_reduction_64_case7 sc ofs r1 r2 symb n1 n2 + | addr, args, vl => addr_strength_reduction_64_default addr args vl + end. + +Definition 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_strength_reduction_64_match addr args vl with + | addr_strength_reduction_64_case1 ofs r1 symb n => (* Aindexed ofs, r1 :: nil, Ptr(Gl symb n) :: nil *) + (Aglobal symb (Ptrofs.add n (Ptrofs.repr ofs)), nil) + | addr_strength_reduction_64_case2 ofs r1 n => (* Aindexed ofs, r1 :: nil, Ptr(Stk n) :: nil *) + (Ainstack (Ptrofs.add n (Ptrofs.repr ofs)), nil) + | addr_strength_reduction_64_case3 ofs r1 r2 symb n1 n2 => (* 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) + | addr_strength_reduction_64_case4 ofs r1 r2 n1 symb n2 => (* 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) + | addr_strength_reduction_64_case5 ofs r1 r2 n1 n2 => (* 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) + | addr_strength_reduction_64_case6 ofs r1 r2 n1 n2 => (* 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) + | addr_strength_reduction_64_case7 sc ofs r1 r2 symb n1 n2 => (* 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_default addr args vl => + addr_strength_reduction_64_generic addr args vl + end. + + +Definition addr_strength_reduction + (addr: addressing) (args: list reg) (vl: list aval) := + let addr_args' := + if Archi.ptr64 + then addr_strength_reduction_64 addr args vl + else addr_strength_reduction_32 addr args vl in + if addressing_valid (fst addr_args') then addr_args' else (addr, args). + +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) := + if Int.eq n Int.one then + (Omove, r1 :: nil) + else + 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) := + if Int.eq n Int.one then + (Omove, r1 :: nil) + else + 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). + +(** Original definition: +<< +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 + | Osel c ty, r1 :: r2 :: args, v1 :: v2 :: vl => make_select c ty r1 r2 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. +>> +*) + +Inductive op_strength_reduction_cases: forall (op: operation) (args: list reg) (vl: list aval), Type := + | op_strength_reduction_case1: forall r1 v1, op_strength_reduction_cases (Ocast8signed) (r1 :: nil) (v1 :: nil) + | op_strength_reduction_case2: forall r1 v1, op_strength_reduction_cases (Ocast8unsigned) (r1 :: nil) (v1 :: nil) + | op_strength_reduction_case3: forall r1 v1, op_strength_reduction_cases (Ocast16signed) (r1 :: nil) (v1 :: nil) + | op_strength_reduction_case4: forall r1 v1, op_strength_reduction_cases (Ocast16unsigned) (r1 :: nil) (v1 :: nil) + | op_strength_reduction_case5: forall r1 r2 v1 n2, op_strength_reduction_cases (Osub) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case6: forall r1 r2 n1 v2, op_strength_reduction_cases (Omul) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | op_strength_reduction_case7: forall r1 r2 v1 n2, op_strength_reduction_cases (Omul) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case8: forall r1 r2 v1 n2, op_strength_reduction_cases (Odiv) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case9: forall r1 r2 v1 n2, op_strength_reduction_cases (Odivu) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case10: forall r1 r2 v1 n2, op_strength_reduction_cases (Omodu) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case11: forall r1 r2 n1 v2, op_strength_reduction_cases (Oand) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | op_strength_reduction_case12: forall r1 r2 v1 n2, op_strength_reduction_cases (Oand) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case13: forall n r1 v1, op_strength_reduction_cases (Oandimm n) (r1 :: nil) (v1 :: nil) + | op_strength_reduction_case14: forall r1 r2 n1 v2, op_strength_reduction_cases (Oor) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | op_strength_reduction_case15: forall r1 r2 v1 n2, op_strength_reduction_cases (Oor) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case16: forall r1 r2 n1 v2, op_strength_reduction_cases (Oxor) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | op_strength_reduction_case17: forall r1 r2 v1 n2, op_strength_reduction_cases (Oxor) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case18: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshl) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case19: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshr) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case20: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshru) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case21: forall addr args vl, op_strength_reduction_cases (Olea addr) (args) (vl) + | op_strength_reduction_case22: forall r1 r2 v1 n2, op_strength_reduction_cases (Osubl) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | op_strength_reduction_case23: forall r1 r2 n1 v2, op_strength_reduction_cases (Omull) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) + | op_strength_reduction_case24: forall r1 r2 v1 n2, op_strength_reduction_cases (Omull) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | op_strength_reduction_case25: forall r1 r2 v1 n2, op_strength_reduction_cases (Odivl) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | op_strength_reduction_case26: forall r1 r2 v1 n2, op_strength_reduction_cases (Odivlu) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | op_strength_reduction_case27: forall r1 r2 v1 n2, op_strength_reduction_cases (Omodlu) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | op_strength_reduction_case28: forall r1 r2 n1 v2, op_strength_reduction_cases (Oandl) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) + | op_strength_reduction_case29: forall r1 r2 v1 n2, op_strength_reduction_cases (Oandl) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | op_strength_reduction_case30: forall n r1 v1, op_strength_reduction_cases (Oandlimm n) (r1 :: nil) (v1 :: nil) + | op_strength_reduction_case31: forall r1 r2 n1 v2, op_strength_reduction_cases (Oorl) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) + | op_strength_reduction_case32: forall r1 r2 v1 n2, op_strength_reduction_cases (Oorl) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | op_strength_reduction_case33: forall r1 r2 n1 v2, op_strength_reduction_cases (Oxorl) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) + | op_strength_reduction_case34: forall r1 r2 v1 n2, op_strength_reduction_cases (Oxorl) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | op_strength_reduction_case35: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshll) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case36: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshrl) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case37: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshrlu) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case38: forall addr args vl, op_strength_reduction_cases (Oleal addr) (args) (vl) + | op_strength_reduction_case39: forall c args vl, op_strength_reduction_cases (Ocmp c) (args) (vl) + | op_strength_reduction_case40: forall c ty r1 r2 args v1 v2 vl, op_strength_reduction_cases (Osel c ty) (r1 :: r2 :: args) (v1 :: v2 :: vl) + | op_strength_reduction_case41: forall r1 r2 v1 n2, op_strength_reduction_cases (Omulf) (r1 :: r2 :: nil) (v1 :: F n2 :: nil) + | op_strength_reduction_case42: forall r1 r2 n1 v2, op_strength_reduction_cases (Omulf) (r1 :: r2 :: nil) (F n1 :: v2 :: nil) + | op_strength_reduction_case43: forall r1 r2 v1 n2, op_strength_reduction_cases (Omulfs) (r1 :: r2 :: nil) (v1 :: FS n2 :: nil) + | op_strength_reduction_case44: forall r1 r2 n1 v2, op_strength_reduction_cases (Omulfs) (r1 :: r2 :: nil) (FS n1 :: v2 :: nil) + | op_strength_reduction_default: forall (op: operation) (args: list reg) (vl: list aval), op_strength_reduction_cases op args vl. + +Definition op_strength_reduction_match (op: operation) (args: list reg) (vl: list aval) := + match op as zz1, args as zz2, vl as zz3 return op_strength_reduction_cases zz1 zz2 zz3 with + | Ocast8signed, r1 :: nil, v1 :: nil => op_strength_reduction_case1 r1 v1 + | Ocast8unsigned, r1 :: nil, v1 :: nil => op_strength_reduction_case2 r1 v1 + | Ocast16signed, r1 :: nil, v1 :: nil => op_strength_reduction_case3 r1 v1 + | Ocast16unsigned, r1 :: nil, v1 :: nil => op_strength_reduction_case4 r1 v1 + | Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case5 r1 r2 v1 n2 + | Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case6 r1 r2 n1 v2 + | Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case7 r1 r2 v1 n2 + | Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case8 r1 r2 v1 n2 + | Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case9 r1 r2 v1 n2 + | Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case10 r1 r2 v1 n2 + | Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case11 r1 r2 n1 v2 + | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case12 r1 r2 v1 n2 + | Oandimm n, r1 :: nil, v1 :: nil => op_strength_reduction_case13 n r1 v1 + | Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case14 r1 r2 n1 v2 + | Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case15 r1 r2 v1 n2 + | Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case16 r1 r2 n1 v2 + | Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case17 r1 r2 v1 n2 + | Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case18 r1 r2 v1 n2 + | Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case19 r1 r2 v1 n2 + | Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case20 r1 r2 v1 n2 + | Olea addr, args, vl => op_strength_reduction_case21 addr args vl + | Osubl, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case22 r1 r2 v1 n2 + | Omull, r1 :: r2 :: nil, L n1 :: v2 :: nil => op_strength_reduction_case23 r1 r2 n1 v2 + | Omull, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case24 r1 r2 v1 n2 + | Odivl, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case25 r1 r2 v1 n2 + | Odivlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case26 r1 r2 v1 n2 + | Omodlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case27 r1 r2 v1 n2 + | Oandl, r1 :: r2 :: nil, L n1 :: v2 :: nil => op_strength_reduction_case28 r1 r2 n1 v2 + | Oandl, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case29 r1 r2 v1 n2 + | Oandlimm n, r1 :: nil, v1 :: nil => op_strength_reduction_case30 n r1 v1 + | Oorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => op_strength_reduction_case31 r1 r2 n1 v2 + | Oorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case32 r1 r2 v1 n2 + | Oxorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => op_strength_reduction_case33 r1 r2 n1 v2 + | Oxorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case34 r1 r2 v1 n2 + | Oshll, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case35 r1 r2 v1 n2 + | Oshrl, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case36 r1 r2 v1 n2 + | Oshrlu, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case37 r1 r2 v1 n2 + | Oleal addr, args, vl => op_strength_reduction_case38 addr args vl + | Ocmp c, args, vl => op_strength_reduction_case39 c args vl + | Osel c ty, r1 :: r2 :: args, v1 :: v2 :: vl => op_strength_reduction_case40 c ty r1 r2 args v1 v2 vl + | Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil => op_strength_reduction_case41 r1 r2 v1 n2 + | Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil => op_strength_reduction_case42 r1 r2 n1 v2 + | Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil => op_strength_reduction_case43 r1 r2 v1 n2 + | Omulfs, r1 :: r2 :: nil, FS n1 :: v2 :: nil => op_strength_reduction_case44 r1 r2 n1 v2 + | op, args, vl => op_strength_reduction_default op args vl + end. + +Definition op_strength_reduction (op: operation) (args: list reg) (vl: list aval) := + match op_strength_reduction_match op args vl with + | op_strength_reduction_case1 r1 v1 => (* Ocast8signed, r1 :: nil, v1 :: nil *) + make_cast8signed r1 v1 + | op_strength_reduction_case2 r1 v1 => (* Ocast8unsigned, r1 :: nil, v1 :: nil *) + make_cast8unsigned r1 v1 + | op_strength_reduction_case3 r1 v1 => (* Ocast16signed, r1 :: nil, v1 :: nil *) + make_cast16signed r1 v1 + | op_strength_reduction_case4 r1 v1 => (* Ocast16unsigned, r1 :: nil, v1 :: nil *) + make_cast16unsigned r1 v1 + | op_strength_reduction_case5 r1 r2 v1 n2 => (* Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_addimm (Int.neg n2) r1 + | op_strength_reduction_case6 r1 r2 n1 v2 => (* Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + make_mulimm n1 r2 + | op_strength_reduction_case7 r1 r2 v1 n2 => (* Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_mulimm n2 r1 + | op_strength_reduction_case8 r1 r2 v1 n2 => (* Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_divimm n2 r1 r2 + | op_strength_reduction_case9 r1 r2 v1 n2 => (* Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_divuimm n2 r1 r2 + | op_strength_reduction_case10 r1 r2 v1 n2 => (* Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_moduimm n2 r1 r2 + | op_strength_reduction_case11 r1 r2 n1 v2 => (* Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + make_andimm n1 r2 v2 + | op_strength_reduction_case12 r1 r2 v1 n2 => (* Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_andimm n2 r1 v1 + | op_strength_reduction_case13 n r1 v1 => (* Oandimm n, r1 :: nil, v1 :: nil *) + make_andimm n r1 v1 + | op_strength_reduction_case14 r1 r2 n1 v2 => (* Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + make_orimm n1 r2 + | op_strength_reduction_case15 r1 r2 v1 n2 => (* Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_orimm n2 r1 + | op_strength_reduction_case16 r1 r2 n1 v2 => (* Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + make_xorimm n1 r2 + | op_strength_reduction_case17 r1 r2 v1 n2 => (* Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_xorimm n2 r1 + | op_strength_reduction_case18 r1 r2 v1 n2 => (* Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shlimm n2 r1 r2 + | op_strength_reduction_case19 r1 r2 v1 n2 => (* Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shrimm n2 r1 r2 + | op_strength_reduction_case20 r1 r2 v1 n2 => (* Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shruimm n2 r1 r2 + | op_strength_reduction_case21 addr args vl => (* Olea addr, args, vl *) + let (addr', args') := addr_strength_reduction_32 addr args vl in (Olea addr', args') + | op_strength_reduction_case22 r1 r2 v1 n2 => (* Osubl, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + make_addlimm (Int64.neg n2) r1 + | op_strength_reduction_case23 r1 r2 n1 v2 => (* Omull, r1 :: r2 :: nil, L n1 :: v2 :: nil *) + make_mullimm n1 r2 + | op_strength_reduction_case24 r1 r2 v1 n2 => (* Omull, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + make_mullimm n2 r1 + | op_strength_reduction_case25 r1 r2 v1 n2 => (* Odivl, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + make_divlimm n2 r1 r2 + | op_strength_reduction_case26 r1 r2 v1 n2 => (* Odivlu, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + make_divluimm n2 r1 r2 + | op_strength_reduction_case27 r1 r2 v1 n2 => (* Omodlu, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + make_modluimm n2 r1 r2 + | op_strength_reduction_case28 r1 r2 n1 v2 => (* Oandl, r1 :: r2 :: nil, L n1 :: v2 :: nil *) + make_andlimm n1 r2 v2 + | op_strength_reduction_case29 r1 r2 v1 n2 => (* Oandl, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + make_andlimm n2 r1 v1 + | op_strength_reduction_case30 n r1 v1 => (* Oandlimm n, r1 :: nil, v1 :: nil *) + make_andlimm n r1 v1 + | op_strength_reduction_case31 r1 r2 n1 v2 => (* Oorl, r1 :: r2 :: nil, L n1 :: v2 :: nil *) + make_orlimm n1 r2 + | op_strength_reduction_case32 r1 r2 v1 n2 => (* Oorl, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + make_orlimm n2 r1 + | op_strength_reduction_case33 r1 r2 n1 v2 => (* Oxorl, r1 :: r2 :: nil, L n1 :: v2 :: nil *) + make_xorlimm n1 r2 + | op_strength_reduction_case34 r1 r2 v1 n2 => (* Oxorl, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + make_xorlimm n2 r1 + | op_strength_reduction_case35 r1 r2 v1 n2 => (* Oshll, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shllimm n2 r1 r2 + | op_strength_reduction_case36 r1 r2 v1 n2 => (* Oshrl, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shrlimm n2 r1 r2 + | op_strength_reduction_case37 r1 r2 v1 n2 => (* Oshrlu, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shrluimm n2 r1 r2 + | op_strength_reduction_case38 addr args vl => (* Oleal addr, args, vl *) + let (addr', args') := addr_strength_reduction_64 addr args vl in (Oleal addr', args') + | op_strength_reduction_case39 c args vl => (* Ocmp c, args, vl *) + make_cmp c args vl + | op_strength_reduction_case40 c ty r1 r2 args v1 v2 vl => (* Osel c ty, r1 :: r2 :: args, v1 :: v2 :: vl *) + make_select c ty r1 r2 args vl + | op_strength_reduction_case41 r1 r2 v1 n2 => (* Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil *) + make_mulfimm n2 r1 r1 r2 + | op_strength_reduction_case42 r1 r2 n1 v2 => (* Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil *) + make_mulfimm n1 r2 r1 r2 + | op_strength_reduction_case43 r1 r2 v1 n2 => (* Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil *) + make_mulfsimm n2 r1 r1 r2 + | op_strength_reduction_case44 r1 r2 n1 v2 => (* Omulfs, r1 :: r2 :: nil, FS n1 :: v2 :: nil *) + make_mulfsimm n1 r2 r1 r2 + | op_strength_reduction_default op args vl => + (op, args) + end. + diff --git a/verilog/ConstpropOp.vp b/verilog/ConstpropOp.vp new file mode 100644 index 00000000..ada8d54a --- /dev/null +++ b/verilog/ConstpropOp.vp @@ -0,0 +1,434 @@ +(* *********************************************************************) +(* *) +(* 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 ValueAOp. + +(** * 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'). + +Definition make_cmp_imm_eq (c: condition) (args: list reg) (vl: list aval) + (n: int) (r1: reg) (v1: aval) := + 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. + +Definition make_cmp_imm_ne (c: condition) (args: list reg) (vl: list aval) + (n: int) (r1: reg) (v1: aval) := + 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. + +Nondetfunction make_cmp (c: condition) (args: list reg) (vl: list aval) := + match c, args, vl with + | Ccompimm Ceq n, r1 :: nil, v1 :: nil => + make_cmp_imm_eq c args vl n r1 v1 + | Ccompimm Cne n, r1 :: nil, v1 :: nil => + make_cmp_imm_ne c args vl n r1 v1 + | Ccompuimm Ceq n, r1 :: nil, v1 :: nil => + make_cmp_imm_eq c args vl n r1 v1 + | Ccompuimm Cne n, r1 :: nil, v1 :: nil => + make_cmp_imm_ne c args vl n r1 v1 + | _, _, _ => + make_cmp_base c args vl + end. + +Definition make_select (c: condition) (ty: typ) + (r1 r2: reg) (args: list reg) (vl: list aval) := + match resolve_branch (eval_static_condition c vl) with + | Some b => (Omove, (if b then r1 else r2) :: nil) + | None => + let (c', args') := cond_strength_reduction c args vl in + (Osel c' ty, r1 :: r2 :: args') + 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) := + let addr_args' := + if Archi.ptr64 + then addr_strength_reduction_64 addr args vl + else addr_strength_reduction_32 addr args vl in + if addressing_valid (fst addr_args') then addr_args' else (addr, args). + +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) := + if Int.eq n Int.one then + (Omove, r1 :: nil) + else + 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) := + if Int.eq n Int.one then + (Omove, r1 :: nil) + else + 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 + | Osel c ty, r1 :: r2 :: args, v1 :: v2 :: vl => make_select c ty r1 r2 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/verilog/ConstpropOpproof.v b/verilog/ConstpropOpproof.v new file mode 100644 index 00000000..6d2df9c1 --- /dev/null +++ b/verilog/ConstpropOpproof.v @@ -0,0 +1,944 @@ +(* *********************************************************************) +(* *) +(* 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 ValueAOp ValueAnalysis. +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. + intros until res. unfold addr_strength_reduction. + set (aa := if Archi.ptr64 + then addr_strength_reduction_64 addr args vl + else addr_strength_reduction_32 addr args vl). + intros. + destruct (addressing_valid (fst aa)). +- unfold aa, eval_addressing in *. destruct Archi.ptr64. ++ apply addr_strength_reduction_64_correct; auto. ++ apply addr_strength_reduction_32_correct; auto. +- exists res; auto. +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. +- unfold make_cmp_imm_eq. + 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. +- unfold make_cmp_imm_ne. + 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. +- unfold make_cmp_imm_eq. + 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. +- unfold make_cmp_imm_ne. + 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_select_correct: + forall c ty r1 r2 args vl, + vl = map (fun r => AE.get r ae) args -> + let (op', args') := make_select c ty r1 r2 args vl in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some v + /\ Val.lessdef (Val.select (eval_condition c e##args m) e#r1 e#r2 ty) v. +Proof. + unfold make_select; intros. + destruct (resolve_branch (eval_static_condition c vl)) as [b|] eqn:RB. +- exists (if b then e#r1 else e#r2); split. ++ simpl. destruct b; auto. ++ destruct (eval_condition c e##args m) as [b'|] eqn:EC; simpl; auto. + assert (b = b'). + { eapply resolve_branch_sound; eauto. + rewrite <- EC. apply eval_static_condition_sound with bc. + subst vl. exact (aregs_sound _ _ _ args MATCH). } + subst b'. apply Val.lessdef_normalize. +- generalize (cond_strength_reduction_correct c args vl H). + destruct (cond_strength_reduction c args vl) as [cond' args']; intros EQ. + econstructor; split. simpl; eauto. rewrite EQ; 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. + predSpec Int.eq Int.eq_spec n Int.one; intros. subst. rewrite H0 in H. + destruct (e#r1) eqn:?; + try (rewrite Val.divs_one in H; exists (Vint i); split; simpl; try rewrite Heqv0; auto); + inv H; auto. + 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. + predSpec Int.eq Int.eq_spec n Int.one; intros. subst. rewrite H0 in H. + destruct (e#r1) eqn:?; + try (rewrite Val.divu_one in H; exists (Vint i); split; simpl; try rewrite Heqv0; auto); + inv H; auto. + 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. +(* select *) + inv H0. apply make_select_correct; congruence. +(* 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/verilog/Conventions1.v b/verilog/Conventions1.v new file mode 100644 index 00000000..fdd94239 --- /dev/null +++ b/verilog/Conventions1.v @@ -0,0 +1,342 @@ +(* *********************************************************************) +(* *) +(* 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 callee_save_type := mreg_type. + +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 proj_sig_res s with + | Tint | Tany32 => One AX + | Tfloat | Tsingle => One FP0 + | Tany64 => One X0 + | 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 proj_sig_res s with + | Tint | Tlong | Tany32 | Tany64 => One AX + | 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 loc_result, loc_result_32, loc_result_64, mreg_type; + destruct Archi.ptr64; destruct (proj_sig_res sig); 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 (proj_sig_res s); 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 /\ proj_sig_res sg = Tlong + /\ subtype Tint (mreg_type r1) = true /\ subtype Tint (mreg_type r2) = true + /\ Archi.ptr64 = false + end. +Proof. + intros. + unfold loc_result, loc_result_32, loc_result_64, mreg_type; + destruct Archi.ptr64; destruct (proj_sig_res sg); 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, proj_sig_res. + 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. + +(** 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 Z.divide_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 Z.divide_trans with 2; auto. + exists (2 / typealign ty); destruct ty; reflexivity. + } + exploit loc_arguments_64_charact; eauto using Z.divide_0_r. + 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. + +Lemma loc_arguments_main: + loc_arguments signature_main = nil. +Proof. + unfold loc_arguments; destruct Archi.ptr64; reflexivity. +Qed. + +(** ** Normalization of function results *) + +(** In the x86 ABI, a return value of type "char" is returned in + register AL, leaving the top 24 bits of EAX unspecified. + Likewise, a return value of type "short" is returned in register + AH, leaving the top 16 bits of EAX unspecified. Hence, return + values of small integer types need re-normalization after calls. *) + +Definition return_value_needs_normalization (t: rettype) : bool := + match t with + | Tint8signed | Tint8unsigned | Tint16signed | Tint16unsigned => true + | _ => false + end. diff --git a/verilog/Machregs.v b/verilog/Machregs.v new file mode 100644 index 00000000..6f3064b8 --- /dev/null +++ b/verilog/Machregs.v @@ -0,0 +1,368 @@ +(* *********************************************************************) +(* *) +(* 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 := + AX :: 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 + | Osel c op => true + end. + +(* Constraints on constant propagation for builtins *) + +Definition builtin_constraints (ef: external_function) : + list builtin_arg_constraint := + match ef with + | EF_vload _ => OK_addressing :: nil + | EF_vstore _ => OK_addressing :: OK_default :: nil + | EF_memcpy _ _ => OK_addrstack :: OK_addrstack :: nil + | EF_annot kind txt targs => map (fun _ => OK_all) targs + | EF_debug kind txt targs => map (fun _ => OK_all) targs + | _ => nil + end. diff --git a/verilog/Machregsaux.ml b/verilog/Machregsaux.ml new file mode 100644 index 00000000..a48749a5 --- /dev/null +++ b/verilog/Machregsaux.ml @@ -0,0 +1,15 @@ +(* *********************************************************************) +(* *) +(* 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 *) + +let is_scratch_register r = false diff --git a/verilog/Machregsaux.mli b/verilog/Machregsaux.mli new file mode 100644 index 00000000..f3d52849 --- /dev/null +++ b/verilog/Machregsaux.mli @@ -0,0 +1,15 @@ +(* *********************************************************************) +(* *) +(* 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 is_scratch_register: string -> bool diff --git a/verilog/NeedOp.v b/verilog/NeedOp.v new file mode 100644 index 00000000..d9a58fbb --- /dev/null +++ b/verilog/NeedOp.v @@ -0,0 +1,259 @@ +(* *********************************************************************) +(* *) +(* 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 + | Osel c ty => nv :: nv :: 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. +- destruct (eval_condition c args m) as [b|] eqn:EC. + erewrite needs_of_condition_sound by eauto. + apply select_sound; auto. + simpl; 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/verilog/Op.v b/verilog/Op.v new file mode 100644 index 00000000..16d75426 --- /dev/null +++ b/verilog/Op.v @@ -0,0 +1,1521 @@ +(* *********************************************************************) +(* *) +(* 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 BoolEqual. +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. *) + | Osel: condition -> typ -> operation. + (**r [rd = rs1] if condition holds, [rd = rs2] 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 beq_operation: forall (x y: operation), bool. +Proof. + generalize Int.eq_dec Int64.eq_dec Float.eq_dec Float32.eq_dec ident_eq typ_eq eq_addressing eq_condition; boolean_equality. +Defined. + +Definition eq_operation: forall (x y: operation), {x=y} + {x<>y}. +Proof. + decidable_equality_from beq_operation. +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. + The check always succeeds in 32-bit mode because offsets are + always 32-bit integers and are normalized as 32-bit signed integers + during code generation (see [Asmgen.normalize_addrmode_32]). + + Moreover, in 64-bit mode, we use RIP-relative addressing for + access to globals. (This is the "small code model" from the + x86_64 ELF ABI.) Thus, for addressing global variables, + the offset from the variable plus the RIP-relative offset + must fit in 32 bits. The "small code model" guarantees that + this will fit if the offset is between [-2^24] and [2^24-1], + under the assumption that no global variable is bigger than + [2^24] bytes. *) + +Definition offset_in_range (n: Z) : bool := + zle Int.min_signed n && zle n Int.max_signed. + +Definition ptroffset_min := -16777216. (**r [-2^24] *) +Definition ptroffset_max := 16777215. (**r [2^24 - 1] *) + +Definition ptroffset_in_range (n: ptrofs) : bool := + let n := Ptrofs.signed n in zle ptroffset_min n && zle n ptroffset_max. + +Definition addressing_valid (a: addressing) : bool := + if Archi.ptr64 then + 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 => ptroffset_in_range ofs + | Abased s ofs => ptroffset_in_range ofs + | Abasedscaled sc s ofs => ptroffset_in_range ofs + | Ainstack ofs => offset_in_range (Ptrofs.signed ofs) + end + else true. + +(** * 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)) + | Osel c ty, v1::v2::vl => Some(Val.select (eval_condition c vl m) v1 v2 ty) + | _, _ => 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) + | Osel c ty => (ty :: ty :: type_of_condition c, ty) + 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... + unfold Val.select. destruct (eval_condition c vl m). apply Val.normalize_type. exact I. +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 condition_depends_on_memory (c: condition) : bool := + match c with + | Ccompu _ => negb Archi.ptr64 + | Ccompuimm _ _ => negb Archi.ptr64 + | Ccomplu _ => Archi.ptr64 + | Ccompluimm _ _ => Archi.ptr64 + | _ => false + end. + +Definition op_depends_on_memory (op: operation) : bool := + match op with + | Ocmp c => condition_depends_on_memory c + | Osel c ty => condition_depends_on_memory c + | _ => false + end. + +Lemma condition_depends_on_memory_correct: + forall c args m1 m2, + condition_depends_on_memory c = false -> + eval_condition c args m1 = eval_condition c args m2. +Proof. + intros until m2. + destruct c; simpl; intros SF; auto; rewrite ? negb_false_iff in SF; + unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. +Qed. + +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; intros C. +- f_equal; f_equal; apply condition_depends_on_memory_correct; auto. +- destruct args; auto. destruct args; auto. + rewrite (condition_depends_on_memory_correct c args m1 m2 C). + auto. +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. + apply Val.select_inject; auto. + destruct (eval_condition c vl1 m1) eqn:?; auto. + right; symmetry; eapply eval_condition_inj; eauto. +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 Z.add_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. + +(** * Handling of builtin arguments *) + +Definition builtin_arg_ok_1 + (A: Type) (ba: builtin_arg A) (c: builtin_arg_constraint) := + match c, ba with + | OK_all, _ => true + | OK_const, (BA_int _ | BA_long _ | BA_float _ | BA_single _) => true + | OK_addrstack, BA_addrstack _ => true + | OK_addressing, BA_addrstack _ => true + | OK_addressing, BA_addrglobal _ _ => true + | OK_addressing, BA_addptr (BA _) (BA_int _ | BA_long _) => true + | _, _ => false + end. + +Definition builtin_arg_ok + (A: Type) (ba: builtin_arg A) (c: builtin_arg_constraint) := + match ba with + | (BA _ | BA_splitlong (BA _) (BA _)) => true + | _ => builtin_arg_ok_1 ba c + end. diff --git a/verilog/PrintOp.ml b/verilog/PrintOp.ml new file mode 100644 index 00000000..6aa4d450 --- /dev/null +++ b/verilog/PrintOp.ml @@ -0,0 +1,173 @@ +(* *********************************************************************) +(* *) +(* 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) + | Osel (c, ty), r1::r2::args -> + fprintf pp "%a ?%s %a : %a" + (print_condition reg) (c, args) + (PrintAST.name_of_type ty) reg r1 reg r2 + | _ -> fprintf pp "<bad operator>" + + diff --git a/verilog/SelectLong.v b/verilog/SelectLong.v new file mode 100644 index 00000000..3b9df4de --- /dev/null +++ b/verilog/SelectLong.v @@ -0,0 +1,804 @@ +(* *********************************************************************) +(* *) +(* 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. + +(** Original definition: +<< +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. +>> +*) + +Inductive notl_cases: forall (e: expr), Type := + | notl_case1: forall n, notl_cases (Eop (Olongconst n) Enil) + | notl_case2: forall t1, notl_cases (Eop Onotl (t1:::Enil)) + | notl_default: forall (e: expr), notl_cases e. + +Definition notl_match (e: expr) := + match e as zz1 return notl_cases zz1 with + | Eop (Olongconst n) Enil => notl_case1 n + | Eop Onotl (t1:::Enil) => notl_case2 t1 + | e => notl_default e + end. + +Definition notl (e: expr) := + if Archi.splitlong then SplitLong.notl e else match notl_match e with + | notl_case1 n => (* Eop (Olongconst n) Enil *) + longconst (Int64.not n) + | notl_case2 t1 => (* Eop Onotl (t1:::Enil) *) + t1 + | notl_default e => + Eop Onotl (e:::Enil) + end. + + +(** Original definition: +<< +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. +>> +*) + +Inductive andlimm_cases: forall (e2: expr), Type := + | andlimm_case1: forall n2, andlimm_cases (Eop (Olongconst n2) Enil) + | andlimm_case2: forall n2 t2, andlimm_cases (Eop (Oandlimm n2) (t2:::Enil)) + | andlimm_default: forall (e2: expr), andlimm_cases e2. + +Definition andlimm_match (e2: expr) := + match e2 as zz1 return andlimm_cases zz1 with + | Eop (Olongconst n2) Enil => andlimm_case1 n2 + | Eop (Oandlimm n2) (t2:::Enil) => andlimm_case2 n2 t2 + | e2 => andlimm_default e2 + end. + +Definition 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 andlimm_match e2 with + | andlimm_case1 n2 => (* Eop (Olongconst n2) Enil *) + longconst (Int64.and n1 n2) + | andlimm_case2 n2 t2 => (* Eop (Oandlimm n2) (t2:::Enil) *) + Eop (Oandlimm (Int64.and n1 n2)) (t2:::Enil) + | andlimm_default e2 => + Eop (Oandlimm n1) (e2:::Enil) + end. + + +(** Original definition: +<< +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. +>> +*) + +Inductive andl_cases: forall (e1: expr) (e2: expr), Type := + | andl_case1: forall n1 t2, andl_cases (Eop (Olongconst n1) Enil) (t2) + | andl_case2: forall t1 n2, andl_cases (t1) (Eop (Olongconst n2) Enil) + | andl_default: forall (e1: expr) (e2: expr), andl_cases e1 e2. + +Definition andl_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return andl_cases zz1 zz2 with + | Eop (Olongconst n1) Enil, t2 => andl_case1 n1 t2 + | t1, Eop (Olongconst n2) Enil => andl_case2 t1 n2 + | e1, e2 => andl_default e1 e2 + end. + +Definition andl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.andl e1 e2 else match andl_match e1 e2 with + | andl_case1 n1 t2 => (* Eop (Olongconst n1) Enil, t2 *) + andlimm n1 t2 + | andl_case2 t1 n2 => (* t1, Eop (Olongconst n2) Enil *) + andlimm n2 t1 + | andl_default e1 e2 => + Eop Oandl (e1:::e2:::Enil) + end. + + +(** Original definition: +<< +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. +>> +*) + +Inductive orlimm_cases: forall (e2: expr), Type := + | orlimm_case1: forall n2, orlimm_cases (Eop (Olongconst n2) Enil) + | orlimm_case2: forall n2 t2, orlimm_cases (Eop (Oorlimm n2) (t2:::Enil)) + | orlimm_default: forall (e2: expr), orlimm_cases e2. + +Definition orlimm_match (e2: expr) := + match e2 as zz1 return orlimm_cases zz1 with + | Eop (Olongconst n2) Enil => orlimm_case1 n2 + | Eop (Oorlimm n2) (t2:::Enil) => orlimm_case2 n2 t2 + | e2 => orlimm_default e2 + end. + +Definition 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 orlimm_match e2 with + | orlimm_case1 n2 => (* Eop (Olongconst n2) Enil *) + longconst (Int64.or n1 n2) + | orlimm_case2 n2 t2 => (* Eop (Oorlimm n2) (t2:::Enil) *) + Eop (Oorlimm (Int64.or n1 n2)) (t2:::Enil) + | orlimm_default e2 => + Eop (Oorlimm n1) (e2:::Enil) + end. + + +(** Original definition: +<< +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. +>> +*) + +Inductive orl_cases: forall (e1: expr) (e2: expr), Type := + | orl_case1: forall n1 t2, orl_cases (Eop (Olongconst n1) Enil) (t2) + | orl_case2: forall t1 n2, orl_cases (t1) (Eop (Olongconst n2) Enil) + | orl_case3: forall n1 t1 n2 t2, orl_cases (Eop (Oshllimm n1) (t1:::Enil)) (Eop (Oshrluimm n2) (t2:::Enil)) + | orl_case4: forall n2 t2 n1 t1, orl_cases (Eop (Oshrluimm n2) (t2:::Enil)) (Eop (Oshllimm n1) (t1:::Enil)) + | orl_default: forall (e1: expr) (e2: expr), orl_cases e1 e2. + +Definition orl_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return orl_cases zz1 zz2 with + | Eop (Olongconst n1) Enil, t2 => orl_case1 n1 t2 + | t1, Eop (Olongconst n2) Enil => orl_case2 t1 n2 + | Eop (Oshllimm n1) (t1:::Enil), Eop (Oshrluimm n2) (t2:::Enil) => orl_case3 n1 t1 n2 t2 + | Eop (Oshrluimm n2) (t2:::Enil), Eop (Oshllimm n1) (t1:::Enil) => orl_case4 n2 t2 n1 t1 + | e1, e2 => orl_default e1 e2 + end. + +Definition orl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.orl e1 e2 else match orl_match e1 e2 with + | orl_case1 n1 t2 => (* Eop (Olongconst n1) Enil, t2 *) + orlimm n1 t2 + | orl_case2 t1 n2 => (* t1, Eop (Olongconst n2) Enil *) + orlimm n2 t1 + | orl_case3 n1 t1 n2 t2 => (* 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) + | orl_case4 n2 t2 n1 t1 => (* 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) + | orl_default e1 e2 => + Eop Oorl (e1:::e2:::Enil) + end. + + +(** Original definition: +<< +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. +>> +*) + +Inductive xorlimm_cases: forall (e2: expr), Type := + | xorlimm_case1: forall n2, xorlimm_cases (Eop (Olongconst n2) Enil) + | xorlimm_case2: forall n2 t2, xorlimm_cases (Eop (Oxorlimm n2) (t2:::Enil)) + | xorlimm_case3: forall t2, xorlimm_cases (Eop Onotl (t2:::Enil)) + | xorlimm_default: forall (e2: expr), xorlimm_cases e2. + +Definition xorlimm_match (e2: expr) := + match e2 as zz1 return xorlimm_cases zz1 with + | Eop (Olongconst n2) Enil => xorlimm_case1 n2 + | Eop (Oxorlimm n2) (t2:::Enil) => xorlimm_case2 n2 t2 + | Eop Onotl (t2:::Enil) => xorlimm_case3 t2 + | e2 => xorlimm_default e2 + end. + +Definition 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 xorlimm_match e2 with + | xorlimm_case1 n2 => (* Eop (Olongconst n2) Enil *) + longconst (Int64.xor n1 n2) + | xorlimm_case2 n2 t2 => (* Eop (Oxorlimm n2) (t2:::Enil) *) + Eop (Oxorlimm (Int64.xor n1 n2)) (t2:::Enil) + | xorlimm_case3 t2 => (* Eop Onotl (t2:::Enil) *) + Eop (Oxorlimm (Int64.not n1)) (t2:::Enil) + | xorlimm_default e2 => + Eop (Oxorlimm n1) (e2:::Enil) + end. + + +(** Original definition: +<< +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. +>> +*) + +Inductive xorl_cases: forall (e1: expr) (e2: expr), Type := + | xorl_case1: forall n1 t2, xorl_cases (Eop (Olongconst n1) Enil) (t2) + | xorl_case2: forall t1 n2, xorl_cases (t1) (Eop (Olongconst n2) Enil) + | xorl_default: forall (e1: expr) (e2: expr), xorl_cases e1 e2. + +Definition xorl_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return xorl_cases zz1 zz2 with + | Eop (Olongconst n1) Enil, t2 => xorl_case1 n1 t2 + | t1, Eop (Olongconst n2) Enil => xorl_case2 t1 n2 + | e1, e2 => xorl_default e1 e2 + end. + +Definition xorl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.xorl e1 e2 else match xorl_match e1 e2 with + | xorl_case1 n1 t2 => (* Eop (Olongconst n1) Enil, t2 *) + xorlimm n1 t2 + | xorl_case2 t1 n2 => (* t1, Eop (Olongconst n2) Enil *) + xorlimm n2 t1 + | xorl_default e1 e2 => + Eop Oxorl (e1:::e2:::Enil) + end. + + +(** Original definition: +<< +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. +>> +*) + +Inductive shllimm_cases: forall (e1: expr) , Type := + | shllimm_case1: forall n1, shllimm_cases (Eop (Olongconst n1) Enil) + | shllimm_case2: forall n1 t1, shllimm_cases (Eop (Oshllimm n1) (t1:::Enil)) + | shllimm_case3: forall n1 t1, shllimm_cases (Eop (Oleal (Aindexed n1)) (t1:::Enil)) + | shllimm_default: forall (e1: expr) , shllimm_cases e1. + +Definition shllimm_match (e1: expr) := + match e1 as zz1 return shllimm_cases zz1 with + | Eop (Olongconst n1) Enil => shllimm_case1 n1 + | Eop (Oshllimm n1) (t1:::Enil) => shllimm_case2 n1 t1 + | Eop (Oleal (Aindexed n1)) (t1:::Enil) => shllimm_case3 n1 t1 + | e1 => shllimm_default e1 + end. + +Definition 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 shllimm_match e1 with + | shllimm_case1 n1 => (* Eop (Olongconst n1) Enil *) + Eop (Olongconst(Int64.shl' n1 n)) Enil + | shllimm_case2 n1 t1 => (* 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) + | shllimm_case3 n1 t1 => (* 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) + | shllimm_default e1 => + 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. + + +(** Original definition: +<< +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. +>> +*) + +Inductive shrluimm_cases: forall (e1: expr) , Type := + | shrluimm_case1: forall n1, shrluimm_cases (Eop (Olongconst n1) Enil) + | shrluimm_case2: forall n1 t1, shrluimm_cases (Eop (Oshrluimm n1) (t1:::Enil)) + | shrluimm_default: forall (e1: expr) , shrluimm_cases e1. + +Definition shrluimm_match (e1: expr) := + match e1 as zz1 return shrluimm_cases zz1 with + | Eop (Olongconst n1) Enil => shrluimm_case1 n1 + | Eop (Oshrluimm n1) (t1:::Enil) => shrluimm_case2 n1 t1 + | e1 => shrluimm_default e1 + end. + +Definition 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 shrluimm_match e1 with + | shrluimm_case1 n1 => (* Eop (Olongconst n1) Enil *) + Eop (Olongconst(Int64.shru' n1 n)) Enil + | shrluimm_case2 n1 t1 => (* 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) + | shrluimm_default e1 => + Eop (Oshrluimm n) (e1:::Enil) + end. + + +(** Original definition: +<< +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. +>> +*) + +Inductive shrlimm_cases: forall (e1: expr) , Type := + | shrlimm_case1: forall n1, shrlimm_cases (Eop (Olongconst n1) Enil) + | shrlimm_case2: forall n1 t1, shrlimm_cases (Eop (Oshrlimm n1) (t1:::Enil)) + | shrlimm_default: forall (e1: expr) , shrlimm_cases e1. + +Definition shrlimm_match (e1: expr) := + match e1 as zz1 return shrlimm_cases zz1 with + | Eop (Olongconst n1) Enil => shrlimm_case1 n1 + | Eop (Oshrlimm n1) (t1:::Enil) => shrlimm_case2 n1 t1 + | e1 => shrlimm_default e1 + end. + +Definition 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 shrlimm_match e1 with + | shrlimm_case1 n1 => (* Eop (Olongconst n1) Enil *) + Eop (Olongconst(Int64.shr' n1 n)) Enil + | shrlimm_case2 n1 t1 => (* 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) + | shrlimm_default e1 => + 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. + +(** Original definition: +<< +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. +>> +*) + +Inductive addlimm_cases: forall (e: expr), Type := + | addlimm_case1: forall m, addlimm_cases (Eop (Olongconst m) Enil) + | addlimm_case2: forall addr args, addlimm_cases (Eop (Oleal addr) args) + | addlimm_default: forall (e: expr), addlimm_cases e. + +Definition addlimm_match (e: expr) := + match e as zz1 return addlimm_cases zz1 with + | Eop (Olongconst m) Enil => addlimm_case1 m + | Eop (Oleal addr) args => addlimm_case2 addr args + | e => addlimm_default e + end. + +Definition addlimm (n: int64) (e: expr) := + if Int64.eq n Int64.zero then e else match addlimm_match e with + | addlimm_case1 m => (* Eop (Olongconst m) Enil *) + longconst (Int64.add n m) + | addlimm_case2 addr args => (* Eop (Oleal addr) args *) + Eop (Oleal (offset_addressing_total addr (Int64.signed n))) args + | addlimm_default e => + Eop (Oleal (Aindexed (Int64.signed n))) (e ::: Enil) + end. + + +(** Original definition: +<< +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. +>> +*) + +Inductive addl_cases: forall (e1: expr) (e2: expr), Type := + | addl_case1: forall n1 t2, addl_cases (Eop (Olongconst n1) Enil) (t2) + | addl_case2: forall t1 n2, addl_cases (t1) (Eop (Olongconst n2) Enil) + | addl_case3: forall n1 t1 n2 t2, addl_cases (Eop (Oleal (Aindexed n1)) (t1:::Enil)) (Eop (Oleal (Aindexed n2)) (t2:::Enil)) + | addl_case4: forall n1 t1 sc n2 t2, addl_cases (Eop (Oleal (Aindexed n1)) (t1:::Enil)) (Eop (Oleal (Ascaled sc n2)) (t2:::Enil)) + | addl_case5: forall sc n1 t1 n2 t2, addl_cases (Eop (Oleal (Ascaled sc n1)) (t1:::Enil)) (Eop (Oleal (Aindexed n2)) (t2:::Enil)) + | addl_case6: forall sc n t1 t2, addl_cases (Eop (Oleal (Ascaled sc n)) (t1:::Enil)) (t2) + | addl_case7: forall t1 sc n t2, addl_cases (t1) (Eop (Oleal (Ascaled sc n)) (t2:::Enil)) + | addl_case8: forall n t1 t2, addl_cases (Eop (Oleal (Aindexed n)) (t1:::Enil)) (t2) + | addl_case9: forall t1 n t2, addl_cases (t1) (Eop (Oleal (Aindexed n)) (t2:::Enil)) + | addl_default: forall (e1: expr) (e2: expr), addl_cases e1 e2. + +Definition addl_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return addl_cases zz1 zz2 with + | Eop (Olongconst n1) Enil, t2 => addl_case1 n1 t2 + | t1, Eop (Olongconst n2) Enil => addl_case2 t1 n2 + | Eop (Oleal (Aindexed n1)) (t1:::Enil), Eop (Oleal (Aindexed n2)) (t2:::Enil) => addl_case3 n1 t1 n2 t2 + | Eop (Oleal (Aindexed n1)) (t1:::Enil), Eop (Oleal (Ascaled sc n2)) (t2:::Enil) => addl_case4 n1 t1 sc n2 t2 + | Eop (Oleal (Ascaled sc n1)) (t1:::Enil), Eop (Oleal (Aindexed n2)) (t2:::Enil) => addl_case5 sc n1 t1 n2 t2 + | Eop (Oleal (Ascaled sc n)) (t1:::Enil), t2 => addl_case6 sc n t1 t2 + | t1, Eop (Oleal (Ascaled sc n)) (t2:::Enil) => addl_case7 t1 sc n t2 + | Eop (Oleal (Aindexed n)) (t1:::Enil), t2 => addl_case8 n t1 t2 + | t1, Eop (Oleal (Aindexed n)) (t2:::Enil) => addl_case9 t1 n t2 + | e1, e2 => addl_default e1 e2 + end. + +Definition addl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.addl e1 e2 else match addl_match e1 e2 with + | addl_case1 n1 t2 => (* Eop (Olongconst n1) Enil, t2 *) + addlimm n1 t2 + | addl_case2 t1 n2 => (* t1, Eop (Olongconst n2) Enil *) + addlimm n2 t1 + | addl_case3 n1 t1 n2 t2 => (* Eop (Oleal (Aindexed n1)) (t1:::Enil), Eop (Oleal (Aindexed n2)) (t2:::Enil) *) + Eop (Oleal (Aindexed2 (n1 + n2))) (t1:::t2:::Enil) + | addl_case4 n1 t1 sc n2 t2 => (* Eop (Oleal (Aindexed n1)) (t1:::Enil), Eop (Oleal (Ascaled sc n2)) (t2:::Enil) *) + Eop (Oleal (Aindexed2scaled sc (n1 + n2))) (t1:::t2:::Enil) + | addl_case5 sc n1 t1 n2 t2 => (* Eop (Oleal (Ascaled sc n1)) (t1:::Enil), Eop (Oleal (Aindexed n2)) (t2:::Enil) *) + Eop (Oleal (Aindexed2scaled sc (n1 + n2))) (t2:::t1:::Enil) + | addl_case6 sc n t1 t2 => (* Eop (Oleal (Ascaled sc n)) (t1:::Enil), t2 *) + Eop (Oleal (Aindexed2scaled sc n)) (t2:::t1:::Enil) + | addl_case7 t1 sc n t2 => (* t1, Eop (Oleal (Ascaled sc n)) (t2:::Enil) *) + Eop (Oleal (Aindexed2scaled sc n)) (t1:::t2:::Enil) + | addl_case8 n t1 t2 => (* Eop (Oleal (Aindexed n)) (t1:::Enil), t2 *) + Eop (Oleal (Aindexed2 n)) (t1:::t2:::Enil) + | addl_case9 t1 n t2 => (* t1, Eop (Oleal (Aindexed n)) (t2:::Enil) *) + Eop (Oleal (Aindexed2 n)) (t1:::t2:::Enil) + | addl_default e1 e2 => + 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. + +(** Original definition: +<< +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. +>> +*) + +Inductive subl_cases: forall (e1: expr) (e2: expr), Type := + | subl_case1: forall t1 n2, subl_cases (t1) (Eop (Olongconst n2) Enil) + | subl_case2: forall n1 t1 n2 t2, subl_cases (Eop (Oleal (Aindexed n1)) (t1:::Enil)) (Eop (Oleal (Aindexed n2)) (t2:::Enil)) + | subl_case3: forall n1 t1 t2, subl_cases (Eop (Oleal (Aindexed n1)) (t1:::Enil)) (t2) + | subl_case4: forall t1 n2 t2, subl_cases (t1) (Eop (Oleal (Aindexed n2)) (t2:::Enil)) + | subl_default: forall (e1: expr) (e2: expr), subl_cases e1 e2. + +Definition subl_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return subl_cases zz1 zz2 with + | t1, Eop (Olongconst n2) Enil => subl_case1 t1 n2 + | Eop (Oleal (Aindexed n1)) (t1:::Enil), Eop (Oleal (Aindexed n2)) (t2:::Enil) => subl_case2 n1 t1 n2 t2 + | Eop (Oleal (Aindexed n1)) (t1:::Enil), t2 => subl_case3 n1 t1 t2 + | t1, Eop (Oleal (Aindexed n2)) (t2:::Enil) => subl_case4 t1 n2 t2 + | e1, e2 => subl_default e1 e2 + end. + +Definition subl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.subl e1 e2 else match subl_match e1 e2 with + | subl_case1 t1 n2 => (* t1, Eop (Olongconst n2) Enil *) + addlimm (Int64.neg n2) t1 + | subl_case2 n1 t1 n2 t2 => (* Eop (Oleal (Aindexed n1)) (t1:::Enil), Eop (Oleal (Aindexed n2)) (t2:::Enil) *) + addlimm (Int64.repr (n1 - n2)) (Eop Osubl (t1:::t2:::Enil)) + | subl_case3 n1 t1 t2 => (* Eop (Oleal (Aindexed n1)) (t1:::Enil), t2 *) + addlimm (Int64.repr n1) (Eop Osubl (t1:::t2:::Enil)) + | subl_case4 t1 n2 t2 => (* t1, Eop (Oleal (Aindexed n2)) (t2:::Enil) *) + addlimm (Int64.repr (- n2)) (Eop Osubl (t1:::t2:::Enil)) + | subl_default e1 e2 => + 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. + +(** Original definition: +<< +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. +>> +*) + +Inductive mullimm_cases: forall (e2: expr), Type := + | mullimm_case1: forall n2, mullimm_cases (Eop (Olongconst n2) Enil) + | mullimm_case2: forall n2 t2, mullimm_cases (Eop (Oleal (Aindexed n2)) (t2:::Enil)) + | mullimm_default: forall (e2: expr), mullimm_cases e2. + +Definition mullimm_match (e2: expr) := + match e2 as zz1 return mullimm_cases zz1 with + | Eop (Olongconst n2) Enil => mullimm_case1 n2 + | Eop (Oleal (Aindexed n2)) (t2:::Enil) => mullimm_case2 n2 t2 + | e2 => mullimm_default e2 + end. + +Definition 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 mullimm_match e2 with + | mullimm_case1 n2 => (* Eop (Olongconst n2) Enil *) + longconst (Int64.mul n1 n2) + | mullimm_case2 n2 t2 => (* Eop (Oleal (Aindexed n2)) (t2:::Enil) *) + addlimm (Int64.mul n1 (Int64.repr n2)) (mullimm_base n1 t2) + | mullimm_default e2 => + mullimm_base n1 e2 + end. + + +(** Original definition: +<< +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. +>> +*) + +Inductive mull_cases: forall (e1: expr) (e2: expr), Type := + | mull_case1: forall n1 t2, mull_cases (Eop (Olongconst n1) Enil) (t2) + | mull_case2: forall t1 n2, mull_cases (t1) (Eop (Olongconst n2) Enil) + | mull_default: forall (e1: expr) (e2: expr), mull_cases e1 e2. + +Definition mull_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return mull_cases zz1 zz2 with + | Eop (Olongconst n1) Enil, t2 => mull_case1 n1 t2 + | t1, Eop (Olongconst n2) Enil => mull_case2 t1 n2 + | e1, e2 => mull_default e1 e2 + end. + +Definition mull (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.mull e1 e2 else match mull_match e1 e2 with + | mull_case1 n1 t2 => (* Eop (Olongconst n1) Enil, t2 *) + mullimm n1 t2 + | mull_case2 t1 n2 => (* t1, Eop (Olongconst n2) Enil *) + mullimm n2 t1 + | mull_default e1 e2 => + 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/verilog/SelectLong.vp b/verilog/SelectLong.vp new file mode 100644 index 00000000..b213e23f --- /dev/null +++ b/verilog/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/verilog/SelectLongproof.v b/verilog/SelectLongproof.v new file mode 100644 index 00000000..3bef632d --- /dev/null +++ b/verilog/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. + +Local Open Scope cminorsel_scope. +Local Open 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/verilog/SelectOp.v b/verilog/SelectOp.v new file mode 100644 index 00000000..d477d7bd --- /dev/null +++ b/verilog/SelectOp.v @@ -0,0 +1,1549 @@ +(* *********************************************************************) +(* *) +(* 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 Builtins. +Require Import Op CminorSel. +Require Archi. + +Local Open 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 *) + +(** Original definition: +<< +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. +>> +*) + +Inductive notint_cases: forall (e: expr), Type := + | notint_case1: forall n, notint_cases (Eop (Ointconst n) Enil) + | notint_case2: forall n e1, notint_cases (Eop (Oxorimm n) (e1 ::: Enil)) + | notint_default: forall (e: expr), notint_cases e. + +Definition notint_match (e: expr) := + match e as zz1 return notint_cases zz1 with + | Eop (Ointconst n) Enil => notint_case1 n + | Eop (Oxorimm n) (e1 ::: Enil) => notint_case2 n e1 + | e => notint_default e + end. + +Definition notint (e: expr) := + match notint_match e with + | notint_case1 n => (* Eop (Ointconst n) Enil *) + Eop (Ointconst (Int.not n)) Enil + | notint_case2 n e1 => (* Eop (Oxorimm n) (e1 ::: Enil) *) + Eop (Oxorimm (Int.not n)) (e1 ::: Enil) + | notint_default e => + Eop Onot (e ::: Enil) + end. + + +(** ** Integer addition and pointer addition *) + +(** Original definition: +<< +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. +>> +*) + +Inductive addimm_cases: forall (e: expr), Type := + | addimm_case1: forall m, addimm_cases (Eop (Ointconst m) Enil) + | addimm_case2: forall addr args, addimm_cases (Eop (Olea addr) args) + | addimm_default: forall (e: expr), addimm_cases e. + +Definition addimm_match (e: expr) := + match e as zz1 return addimm_cases zz1 with + | Eop (Ointconst m) Enil => addimm_case1 m + | Eop (Olea addr) args => addimm_case2 addr args + | e => addimm_default e + end. + +Definition addimm (n: int) (e: expr) := + if Int.eq n Int.zero then e else match addimm_match e with + | addimm_case1 m => (* Eop (Ointconst m) Enil *) + Eop (Ointconst(Int.add n m)) Enil + | addimm_case2 addr args => (* Eop (Olea addr) args *) + Eop (Olea (offset_addressing_total addr (Int.signed n))) args + | addimm_default e => + Eop (Olea (Aindexed (Int.signed n))) (e ::: Enil) + end. + + +(** Original definition: +<< +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. +>> +*) + +Inductive add_cases: forall (e1: expr) (e2: expr), Type := + | add_case1: forall n1 t2, add_cases (Eop (Ointconst n1) Enil) (t2) + | add_case2: forall t1 n2, add_cases (t1) (Eop (Ointconst n2) Enil) + | add_case3: forall n1 t1 n2 t2, add_cases (Eop (Olea (Aindexed n1)) (t1:::Enil)) (Eop (Olea (Aindexed n2)) (t2:::Enil)) + | add_case4: forall n1 t1 sc n2 t2, add_cases (Eop (Olea (Aindexed n1)) (t1:::Enil)) (Eop (Olea (Ascaled sc n2)) (t2:::Enil)) + | add_case5: forall sc n1 t1 n2 t2, add_cases (Eop (Olea (Ascaled sc n1)) (t1:::Enil)) (Eop (Olea (Aindexed n2)) (t2:::Enil)) + | add_case6: forall n1 t1 id ofs, add_cases (Eop (Olea (Aindexed n1)) (t1:::Enil)) (Eop (Olea (Aglobal id ofs)) Enil) + | add_case7: forall id ofs n2 t2, add_cases (Eop (Olea (Aglobal id ofs)) Enil) (Eop (Olea (Aindexed n2)) (t2:::Enil)) + | add_case8: forall sc n1 t1 id ofs, add_cases (Eop (Olea (Ascaled sc n1)) (t1:::Enil)) (Eop (Olea (Aglobal id ofs)) Enil) + | add_case9: forall id ofs sc n2 t2, add_cases (Eop (Olea (Aglobal id ofs)) Enil) (Eop (Olea (Ascaled sc n2)) (t2:::Enil)) + | add_case10: forall sc n t1 t2, add_cases (Eop (Olea (Ascaled sc n)) (t1:::Enil)) (t2) + | add_case11: forall t1 sc n t2, add_cases (t1) (Eop (Olea (Ascaled sc n)) (t2:::Enil)) + | add_case12: forall n t1 t2, add_cases (Eop (Olea (Aindexed n)) (t1:::Enil)) (t2) + | add_case13: forall t1 n t2, add_cases (t1) (Eop (Olea (Aindexed n)) (t2:::Enil)) + | add_default: forall (e1: expr) (e2: expr), add_cases e1 e2. + +Definition add_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return add_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => add_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => add_case2 t1 n2 + | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => add_case3 n1 t1 n2 t2 + | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Ascaled sc n2)) (t2:::Enil) => add_case4 n1 t1 sc n2 t2 + | Eop (Olea (Ascaled sc n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => add_case5 sc n1 t1 n2 t2 + | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aglobal id ofs)) Enil => add_case6 n1 t1 id ofs + | Eop (Olea (Aglobal id ofs)) Enil, Eop (Olea (Aindexed n2)) (t2:::Enil) => add_case7 id ofs n2 t2 + | Eop (Olea (Ascaled sc n1)) (t1:::Enil), Eop (Olea (Aglobal id ofs)) Enil => add_case8 sc n1 t1 id ofs + | Eop (Olea (Aglobal id ofs)) Enil, Eop (Olea (Ascaled sc n2)) (t2:::Enil) => add_case9 id ofs sc n2 t2 + | Eop (Olea (Ascaled sc n)) (t1:::Enil), t2 => add_case10 sc n t1 t2 + | t1, Eop (Olea (Ascaled sc n)) (t2:::Enil) => add_case11 t1 sc n t2 + | Eop (Olea (Aindexed n)) (t1:::Enil), t2 => add_case12 n t1 t2 + | t1, Eop (Olea (Aindexed n)) (t2:::Enil) => add_case13 t1 n t2 + | e1, e2 => add_default e1 e2 + end. + +Definition add (e1: expr) (e2: expr) := + match add_match e1 e2 with + | add_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) + addimm n1 t2 + | add_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + addimm n2 t1 + | add_case3 n1 t1 n2 t2 => (* Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) *) + Eop (Olea (Aindexed2 (n1 + n2))) (t1:::t2:::Enil) + | add_case4 n1 t1 sc n2 t2 => (* Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Ascaled sc n2)) (t2:::Enil) *) + Eop (Olea (Aindexed2scaled sc (n1 + n2))) (t1:::t2:::Enil) + | add_case5 sc n1 t1 n2 t2 => (* Eop (Olea (Ascaled sc n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) *) + Eop (Olea (Aindexed2scaled sc (n1 + n2))) (t2:::t1:::Enil) + | add_case6 n1 t1 id ofs => (* Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aglobal id ofs)) Enil *) + Eop (Olea (Abased id (Ptrofs.add ofs (Ptrofs.repr n1)))) (t1:::Enil) + | add_case7 id ofs n2 t2 => (* Eop (Olea (Aglobal id ofs)) Enil, Eop (Olea (Aindexed n2)) (t2:::Enil) *) + Eop (Olea (Abased id (Ptrofs.add ofs (Ptrofs.repr n2)))) (t2:::Enil) + | add_case8 sc n1 t1 id ofs => (* 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) + | add_case9 id ofs sc n2 t2 => (* 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) + | add_case10 sc n t1 t2 => (* Eop (Olea (Ascaled sc n)) (t1:::Enil), t2 *) + Eop (Olea (Aindexed2scaled sc n)) (t2:::t1:::Enil) + | add_case11 t1 sc n t2 => (* t1, Eop (Olea (Ascaled sc n)) (t2:::Enil) *) + Eop (Olea (Aindexed2scaled sc n)) (t1:::t2:::Enil) + | add_case12 n t1 t2 => (* Eop (Olea (Aindexed n)) (t1:::Enil), t2 *) + Eop (Olea (Aindexed2 n)) (t1:::t2:::Enil) + | add_case13 t1 n t2 => (* t1, Eop (Olea (Aindexed n)) (t2:::Enil) *) + Eop (Olea (Aindexed2 n)) (t1:::t2:::Enil) + | add_default e1 e2 => + Eop (Olea (Aindexed2 0)) (e1:::e2:::Enil) + end. + + +(** ** Opposite *) + +(** Original definition: +<< +Nondetfunction negint (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ointconst (Int.neg n)) Enil + | _ => Eop Oneg (e ::: Enil) + end. +>> +*) + +Inductive negint_cases: forall (e: expr), Type := + | negint_case1: forall n, negint_cases (Eop (Ointconst n) Enil) + | negint_default: forall (e: expr), negint_cases e. + +Definition negint_match (e: expr) := + match e as zz1 return negint_cases zz1 with + | Eop (Ointconst n) Enil => negint_case1 n + | e => negint_default e + end. + +Definition negint (e: expr) := + match negint_match e with + | negint_case1 n => (* Eop (Ointconst n) Enil *) + Eop (Ointconst (Int.neg n)) Enil + | negint_default e => + Eop Oneg (e ::: Enil) + end. + + +(** ** Integer and pointer subtraction *) + +(** Original definition: +<< +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. +>> +*) + +Inductive sub_cases: forall (e1: expr) (e2: expr), Type := + | sub_case1: forall t1 n2, sub_cases (t1) (Eop (Ointconst n2) Enil) + | sub_case2: forall n1 t1 n2 t2, sub_cases (Eop (Olea (Aindexed n1)) (t1:::Enil)) (Eop (Olea (Aindexed n2)) (t2:::Enil)) + | sub_case3: forall n1 t1 t2, sub_cases (Eop (Olea (Aindexed n1)) (t1:::Enil)) (t2) + | sub_case4: forall t1 n2 t2, sub_cases (t1) (Eop (Olea (Aindexed n2)) (t2:::Enil)) + | sub_default: forall (e1: expr) (e2: expr), sub_cases e1 e2. + +Definition sub_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return sub_cases zz1 zz2 with + | t1, Eop (Ointconst n2) Enil => sub_case1 t1 n2 + | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => sub_case2 n1 t1 n2 t2 + | Eop (Olea (Aindexed n1)) (t1:::Enil), t2 => sub_case3 n1 t1 t2 + | t1, Eop (Olea (Aindexed n2)) (t2:::Enil) => sub_case4 t1 n2 t2 + | e1, e2 => sub_default e1 e2 + end. + +Definition sub (e1: expr) (e2: expr) := + match sub_match e1 e2 with + | sub_case1 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + addimm (Int.neg n2) t1 + | sub_case2 n1 t1 n2 t2 => (* Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) *) + addimm (Int.repr (n1 - n2)) (Eop Osub (t1:::t2:::Enil)) + | sub_case3 n1 t1 t2 => (* Eop (Olea (Aindexed n1)) (t1:::Enil), t2 *) + addimm (Int.repr n1) (Eop Osub (t1:::t2:::Enil)) + | sub_case4 t1 n2 t2 => (* t1, Eop (Olea (Aindexed n2)) (t2:::Enil) *) + addimm (Int.repr (-n2)) (Eop Osub (t1:::t2:::Enil)) + | sub_default e1 e2 => + 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). + +(** Original definition: +<< +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. +>> +*) + +Inductive shlimm_cases: forall (e1: expr) , Type := + | shlimm_case1: forall n1, shlimm_cases (Eop (Ointconst n1) Enil) + | shlimm_case2: forall n1 t1, shlimm_cases (Eop (Oshlimm n1) (t1:::Enil)) + | shlimm_case3: forall n1 t1, shlimm_cases (Eop (Olea (Aindexed n1)) (t1:::Enil)) + | shlimm_default: forall (e1: expr) , shlimm_cases e1. + +Definition shlimm_match (e1: expr) := + match e1 as zz1 return shlimm_cases zz1 with + | Eop (Ointconst n1) Enil => shlimm_case1 n1 + | Eop (Oshlimm n1) (t1:::Enil) => shlimm_case2 n1 t1 + | Eop (Olea (Aindexed n1)) (t1:::Enil) => shlimm_case3 n1 t1 + | e1 => shlimm_default e1 + end. + +Definition 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 shlimm_match e1 with + | shlimm_case1 n1 => (* Eop (Ointconst n1) Enil *) + Eop (Ointconst(Int.shl n1 n)) Enil + | shlimm_case2 n1 t1 => (* 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) + | shlimm_case3 n1 t1 => (* 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) + | shlimm_default e1 => + 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. + + +(** Original definition: +<< +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. +>> +*) + +Inductive shruimm_cases: forall (e1: expr) , Type := + | shruimm_case1: forall n1, shruimm_cases (Eop (Ointconst n1) Enil) + | shruimm_case2: forall n1 t1, shruimm_cases (Eop (Oshruimm n1) (t1:::Enil)) + | shruimm_default: forall (e1: expr) , shruimm_cases e1. + +Definition shruimm_match (e1: expr) := + match e1 as zz1 return shruimm_cases zz1 with + | Eop (Ointconst n1) Enil => shruimm_case1 n1 + | Eop (Oshruimm n1) (t1:::Enil) => shruimm_case2 n1 t1 + | e1 => shruimm_default e1 + end. + +Definition 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 shruimm_match e1 with + | shruimm_case1 n1 => (* Eop (Ointconst n1) Enil *) + Eop (Ointconst(Int.shru n1 n)) Enil + | shruimm_case2 n1 t1 => (* 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) + | shruimm_default e1 => + Eop (Oshruimm n) (e1:::Enil) + end. + + +(** Original definition: +<< +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. +>> +*) + +Inductive shrimm_cases: forall (e1: expr) , Type := + | shrimm_case1: forall n1, shrimm_cases (Eop (Ointconst n1) Enil) + | shrimm_case2: forall n1 t1, shrimm_cases (Eop (Oshrimm n1) (t1:::Enil)) + | shrimm_default: forall (e1: expr) , shrimm_cases e1. + +Definition shrimm_match (e1: expr) := + match e1 as zz1 return shrimm_cases zz1 with + | Eop (Ointconst n1) Enil => shrimm_case1 n1 + | Eop (Oshrimm n1) (t1:::Enil) => shrimm_case2 n1 t1 + | e1 => shrimm_default e1 + end. + +Definition 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 shrimm_match e1 with + | shrimm_case1 n1 => (* Eop (Ointconst n1) Enil *) + Eop (Ointconst(Int.shr n1 n)) Enil + | shrimm_case2 n1 t1 => (* 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) + | shrimm_default e1 => + 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. + +(** Original definition: +<< +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. +>> +*) + +Inductive mulimm_cases: forall (e2: expr), Type := + | mulimm_case1: forall n2, mulimm_cases (Eop (Ointconst n2) Enil) + | mulimm_case2: forall n2 t2, mulimm_cases (Eop (Olea (Aindexed n2)) (t2:::Enil)) + | mulimm_default: forall (e2: expr), mulimm_cases e2. + +Definition mulimm_match (e2: expr) := + match e2 as zz1 return mulimm_cases zz1 with + | Eop (Ointconst n2) Enil => mulimm_case1 n2 + | Eop (Olea (Aindexed n2)) (t2:::Enil) => mulimm_case2 n2 t2 + | e2 => mulimm_default e2 + end. + +Definition mulimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil else if Int.eq n1 Int.one then e2 else match mulimm_match e2 with + | mulimm_case1 n2 => (* Eop (Ointconst n2) Enil *) + Eop (Ointconst(Int.mul n1 n2)) Enil + | mulimm_case2 n2 t2 => (* Eop (Olea (Aindexed n2)) (t2:::Enil) *) + addimm (Int.mul n1 (Int.repr n2)) (mulimm_base n1 t2) + | mulimm_default e2 => + mulimm_base n1 e2 + end. + + +(** Original definition: +<< +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. +>> +*) + +Inductive mul_cases: forall (e1: expr) (e2: expr), Type := + | mul_case1: forall n1 t2, mul_cases (Eop (Ointconst n1) Enil) (t2) + | mul_case2: forall t1 n2, mul_cases (t1) (Eop (Ointconst n2) Enil) + | mul_default: forall (e1: expr) (e2: expr), mul_cases e1 e2. + +Definition mul_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return mul_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => mul_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => mul_case2 t1 n2 + | e1, e2 => mul_default e1 e2 + end. + +Definition mul (e1: expr) (e2: expr) := + match mul_match e1 e2 with + | mul_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) + mulimm n1 t2 + | mul_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + mulimm n2 t1 + | mul_default e1 e2 => + Eop Omul (e1:::e2:::Enil) + end. + + +Definition mulhs (e1: expr) (e2: expr) := Eop Omulhs (e1 ::: e2 ::: Enil). +Definition mulhu (e1: expr) (e2: expr) := Eop Omulhu (e1 ::: e2 ::: Enil). + +(** ** Bitwise and, or, xor *) + +(** Original definition: +<< +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. +>> +*) + +Inductive andimm_cases: forall (e2: expr), Type := + | andimm_case1: forall n2, andimm_cases (Eop (Ointconst n2) Enil) + | andimm_case2: forall n2 t2, andimm_cases (Eop (Oandimm n2) (t2:::Enil)) + | andimm_case3: forall t2, andimm_cases (Eop Ocast8unsigned (t2:::Enil)) + | andimm_case4: forall t2, andimm_cases (Eop Ocast16unsigned (t2:::Enil)) + | andimm_default: forall (e2: expr), andimm_cases e2. + +Definition andimm_match (e2: expr) := + match e2 as zz1 return andimm_cases zz1 with + | Eop (Ointconst n2) Enil => andimm_case1 n2 + | Eop (Oandimm n2) (t2:::Enil) => andimm_case2 n2 t2 + | Eop Ocast8unsigned (t2:::Enil) => andimm_case3 t2 + | Eop Ocast16unsigned (t2:::Enil) => andimm_case4 t2 + | e2 => andimm_default e2 + end. + +Definition 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 andimm_match e2 with + | andimm_case1 n2 => (* Eop (Ointconst n2) Enil *) + Eop (Ointconst (Int.and n1 n2)) Enil + | andimm_case2 n2 t2 => (* Eop (Oandimm n2) (t2:::Enil) *) + Eop (Oandimm (Int.and n1 n2)) (t2:::Enil) + | andimm_case3 t2 => (* Eop Ocast8unsigned (t2:::Enil) *) + Eop (Oandimm (Int.and n1 (Int.repr 255))) (t2:::Enil) + | andimm_case4 t2 => (* Eop Ocast16unsigned (t2:::Enil) *) + Eop (Oandimm (Int.and n1 (Int.repr 65535))) (t2:::Enil) + | andimm_default e2 => + Eop (Oandimm n1) (e2:::Enil) + end. + + +(** Original definition: +<< +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. +>> +*) + +Inductive and_cases: forall (e1: expr) (e2: expr), Type := + | and_case1: forall n1 t2, and_cases (Eop (Ointconst n1) Enil) (t2) + | and_case2: forall t1 n2, and_cases (t1) (Eop (Ointconst n2) Enil) + | and_default: forall (e1: expr) (e2: expr), and_cases e1 e2. + +Definition and_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return and_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => and_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => and_case2 t1 n2 + | e1, e2 => and_default e1 e2 + end. + +Definition and (e1: expr) (e2: expr) := + match and_match e1 e2 with + | and_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) + andimm n1 t2 + | and_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + andimm n2 t1 + | and_default e1 e2 => + Eop Oand (e1:::e2:::Enil) + end. + + +(** Original definition: +<< +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. +>> +*) + +Inductive orimm_cases: forall (e2: expr), Type := + | orimm_case1: forall n2, orimm_cases (Eop (Ointconst n2) Enil) + | orimm_case2: forall n2 t2, orimm_cases (Eop (Oorimm n2) (t2:::Enil)) + | orimm_default: forall (e2: expr), orimm_cases e2. + +Definition orimm_match (e2: expr) := + match e2 as zz1 return orimm_cases zz1 with + | Eop (Ointconst n2) Enil => orimm_case1 n2 + | Eop (Oorimm n2) (t2:::Enil) => orimm_case2 n2 t2 + | e2 => orimm_default e2 + end. + +Definition 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 orimm_match e2 with + | orimm_case1 n2 => (* Eop (Ointconst n2) Enil *) + Eop (Ointconst (Int.or n1 n2)) Enil + | orimm_case2 n2 t2 => (* Eop (Oorimm n2) (t2:::Enil) *) + Eop (Oorimm (Int.or n1 n2)) (t2:::Enil) + | orimm_default e2 => + 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. + +(** Original definition: +<< +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. +>> +*) + +Inductive or_cases: forall (e1: expr) (e2: expr), Type := + | or_case1: forall n1 t2, or_cases (Eop (Ointconst n1) Enil) (t2) + | or_case2: forall t1 n2, or_cases (t1) (Eop (Ointconst n2) Enil) + | or_case3: forall n1 t1 n2 t2, or_cases (Eop (Oshlimm n1) (t1:::Enil)) (Eop (Oshruimm n2) (t2:::Enil)) + | or_case4: forall n2 t2 n1 t1, or_cases (Eop (Oshruimm n2) (t2:::Enil)) (Eop (Oshlimm n1) (t1:::Enil)) + | or_default: forall (e1: expr) (e2: expr), or_cases e1 e2. + +Definition or_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return or_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => or_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => or_case2 t1 n2 + | Eop (Oshlimm n1) (t1:::Enil), Eop (Oshruimm n2) (t2:::Enil) => or_case3 n1 t1 n2 t2 + | Eop (Oshruimm n2) (t2:::Enil), Eop (Oshlimm n1) (t1:::Enil) => or_case4 n2 t2 n1 t1 + | e1, e2 => or_default e1 e2 + end. + +Definition or (e1: expr) (e2: expr) := + match or_match e1 e2 with + | or_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) + orimm n1 t2 + | or_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + orimm n2 t1 + | or_case3 n1 t1 n2 t2 => (* 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) + | or_case4 n2 t2 n1 t1 => (* 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) + | or_default e1 e2 => + Eop Oor (e1:::e2:::Enil) + end. + + +(** Original definition: +<< +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. +>> +*) + +Inductive xorimm_cases: forall (e2: expr), Type := + | xorimm_case1: forall n2, xorimm_cases (Eop (Ointconst n2) Enil) + | xorimm_case2: forall n2 t2, xorimm_cases (Eop (Oxorimm n2) (t2:::Enil)) + | xorimm_case3: forall t2, xorimm_cases (Eop Onot (t2:::Enil)) + | xorimm_default: forall (e2: expr), xorimm_cases e2. + +Definition xorimm_match (e2: expr) := + match e2 as zz1 return xorimm_cases zz1 with + | Eop (Ointconst n2) Enil => xorimm_case1 n2 + | Eop (Oxorimm n2) (t2:::Enil) => xorimm_case2 n2 t2 + | Eop Onot (t2:::Enil) => xorimm_case3 t2 + | e2 => xorimm_default e2 + end. + +Definition xorimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then e2 else match xorimm_match e2 with + | xorimm_case1 n2 => (* Eop (Ointconst n2) Enil *) + Eop (Ointconst (Int.xor n1 n2)) Enil + | xorimm_case2 n2 t2 => (* Eop (Oxorimm n2) (t2:::Enil) *) + Eop (Oxorimm (Int.xor n1 n2)) (t2:::Enil) + | xorimm_case3 t2 => (* Eop Onot (t2:::Enil) *) + Eop (Oxorimm (Int.not n1)) (t2:::Enil) + | xorimm_default e2 => + Eop (Oxorimm n1) (e2:::Enil) + end. + + +(** Original definition: +<< +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. +>> +*) + +Inductive xor_cases: forall (e1: expr) (e2: expr), Type := + | xor_case1: forall n1 t2, xor_cases (Eop (Ointconst n1) Enil) (t2) + | xor_case2: forall t1 n2, xor_cases (t1) (Eop (Ointconst n2) Enil) + | xor_default: forall (e1: expr) (e2: expr), xor_cases e1 e2. + +Definition xor_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return xor_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => xor_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => xor_case2 t1 n2 + | e1, e2 => xor_default e1 e2 + end. + +Definition xor (e1: expr) (e2: expr) := + match xor_match e1 e2 with + | xor_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) + xorimm n1 t2 + | xor_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + xorimm n2 t1 + | xor_default e1 e2 => + 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 *) + +(** Original definition: +<< +Nondetfunction shl (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shlimm e1 n2 + | _ => Eop Oshl (e1:::e2:::Enil) + end. +>> +*) + +Inductive shl_cases: forall (e2: expr), Type := + | shl_case1: forall n2, shl_cases (Eop (Ointconst n2) Enil) + | shl_default: forall (e2: expr), shl_cases e2. + +Definition shl_match (e2: expr) := + match e2 as zz1 return shl_cases zz1 with + | Eop (Ointconst n2) Enil => shl_case1 n2 + | e2 => shl_default e2 + end. + +Definition shl (e1: expr) (e2: expr) := + match shl_match e2 with + | shl_case1 n2 => (* Eop (Ointconst n2) Enil *) + shlimm e1 n2 + | shl_default e2 => + Eop Oshl (e1:::e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction shr (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shrimm e1 n2 + | _ => Eop Oshr (e1:::e2:::Enil) + end. +>> +*) + +Inductive shr_cases: forall (e2: expr), Type := + | shr_case1: forall n2, shr_cases (Eop (Ointconst n2) Enil) + | shr_default: forall (e2: expr), shr_cases e2. + +Definition shr_match (e2: expr) := + match e2 as zz1 return shr_cases zz1 with + | Eop (Ointconst n2) Enil => shr_case1 n2 + | e2 => shr_default e2 + end. + +Definition shr (e1: expr) (e2: expr) := + match shr_match e2 with + | shr_case1 n2 => (* Eop (Ointconst n2) Enil *) + shrimm e1 n2 + | shr_default e2 => + Eop Oshr (e1:::e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction shru (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shruimm e1 n2 + | _ => Eop Oshru (e1:::e2:::Enil) + end. +>> +*) + +Inductive shru_cases: forall (e2: expr), Type := + | shru_case1: forall n2, shru_cases (Eop (Ointconst n2) Enil) + | shru_default: forall (e2: expr), shru_cases e2. + +Definition shru_match (e2: expr) := + match e2 as zz1 return shru_cases zz1 with + | Eop (Ointconst n2) Enil => shru_case1 n2 + | e2 => shru_default e2 + end. + +Definition shru (e1: expr) (e2: expr) := + match shru_match e2 with + | shru_case1 n2 => (* Eop (Ointconst n2) Enil *) + shruimm e1 n2 + | shru_default e2 => + 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 *) + +(** Original definition: +<< +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. +>> +*) + +Inductive compimm_cases: forall (c: comparison) (e1: expr) , Type := + | compimm_case1: forall c n1, compimm_cases (c) (Eop (Ointconst n1) Enil) + | compimm_case2: forall c el, compimm_cases (Ceq) (Eop (Ocmp c) el) + | compimm_case3: forall c el, compimm_cases (Cne) (Eop (Ocmp c) el) + | compimm_case4: forall n1 t1, compimm_cases (Ceq) (Eop (Oandimm n1) (t1 ::: Enil)) + | compimm_case5: forall n1 t1, compimm_cases (Cne) (Eop (Oandimm n1) (t1 ::: Enil)) + | compimm_default: forall (c: comparison) (e1: expr) , compimm_cases c e1. + +Definition compimm_match (c: comparison) (e1: expr) := + match c as zz1, e1 as zz2 return compimm_cases zz1 zz2 with + | c, Eop (Ointconst n1) Enil => compimm_case1 c n1 + | Ceq, Eop (Ocmp c) el => compimm_case2 c el + | Cne, Eop (Ocmp c) el => compimm_case3 c el + | Ceq, Eop (Oandimm n1) (t1 ::: Enil) => compimm_case4 n1 t1 + | Cne, Eop (Oandimm n1) (t1 ::: Enil) => compimm_case5 n1 t1 + | c, e1 => compimm_default c e1 + end. + +Definition compimm (default: comparison -> int -> condition) (sem: comparison -> int -> int -> bool) (c: comparison) (e1: expr) (n2: int) := + match compimm_match c e1 with + | compimm_case1 c n1 => (* c, Eop (Ointconst n1) Enil *) + Eop (Ointconst (if sem c n1 n2 then Int.one else Int.zero)) Enil + | compimm_case2 c el => (* 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 + | compimm_case3 c el => (* 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 + | compimm_case4 n1 t1 => (* 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) + | compimm_case5 n1 t1 => (* 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) + | compimm_default c e1 => + Eop (Ocmp (default c n2)) (e1 ::: Enil) + end. + + +(** Original definition: +<< +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. +>> +*) + +Inductive comp_cases: forall (e1: expr) (e2: expr), Type := + | comp_case1: forall n1 t2, comp_cases (Eop (Ointconst n1) Enil) (t2) + | comp_case2: forall t1 n2, comp_cases (t1) (Eop (Ointconst n2) Enil) + | comp_default: forall (e1: expr) (e2: expr), comp_cases e1 e2. + +Definition comp_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return comp_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => comp_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => comp_case2 t1 n2 + | e1, e2 => comp_default e1 e2 + end. + +Definition comp (c: comparison) (e1: expr) (e2: expr) := + match comp_match e1 e2 with + | comp_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) + compimm Ccompimm Int.cmp (swap_comparison c) t2 n1 + | comp_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + compimm Ccompimm Int.cmp c t1 n2 + | comp_default e1 e2 => + Eop (Ocmp (Ccomp c)) (e1 ::: e2 ::: Enil) + end. + + +(** Original definition: +<< +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. +>> +*) + +Inductive compu_cases: forall (e1: expr) (e2: expr), Type := + | compu_case1: forall n1 t2, compu_cases (Eop (Ointconst n1) Enil) (t2) + | compu_case2: forall t1 n2, compu_cases (t1) (Eop (Ointconst n2) Enil) + | compu_default: forall (e1: expr) (e2: expr), compu_cases e1 e2. + +Definition compu_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return compu_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => compu_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => compu_case2 t1 n2 + | e1, e2 => compu_default e1 e2 + end. + +Definition compu (c: comparison) (e1: expr) (e2: expr) := + match compu_match e1 e2 with + | compu_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) + compimm Ccompuimm Int.cmpu (swap_comparison c) t2 n1 + | compu_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + compimm Ccompuimm Int.cmpu c t1 n2 + | compu_default e1 e2 => + Eop (Ocmp (Ccompu c)) (e1 ::: e2 ::: Enil) + end. + + +Definition compf (c: comparison) (e1: expr) (e2: expr) := + Eop (Ocmp (Ccompf c)) (e1 ::: e2 ::: Enil). + +Definition compfs (c: comparison) (e1: expr) (e2: expr) := + Eop (Ocmp (Ccompfs c)) (e1 ::: e2 ::: Enil). + +(** ** Integer conversions *) + +(** Original definition: +<< +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. +>> +*) + +Inductive cast8unsigned_cases: forall (e: expr), Type := + | cast8unsigned_case1: forall n, cast8unsigned_cases (Eop (Ointconst n) Enil) + | cast8unsigned_case2: forall n t, cast8unsigned_cases (Eop (Oandimm n) (t:::Enil)) + | cast8unsigned_default: forall (e: expr), cast8unsigned_cases e. + +Definition cast8unsigned_match (e: expr) := + match e as zz1 return cast8unsigned_cases zz1 with + | Eop (Ointconst n) Enil => cast8unsigned_case1 n + | Eop (Oandimm n) (t:::Enil) => cast8unsigned_case2 n t + | e => cast8unsigned_default e + end. + +Definition cast8unsigned (e: expr) := + match cast8unsigned_match e with + | cast8unsigned_case1 n => (* Eop (Ointconst n) Enil *) + Eop (Ointconst (Int.zero_ext 8 n)) Enil + | cast8unsigned_case2 n t => (* Eop (Oandimm n) (t:::Enil) *) + andimm (Int.and (Int.repr 255) n) t + | cast8unsigned_default e => + Eop Ocast8unsigned (e:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction cast8signed (e: expr) := + match e with + | Eop (Ointconst n) Enil => + Eop (Ointconst (Int.sign_ext 8 n)) Enil + | _ => + Eop Ocast8signed (e ::: Enil) + end. +>> +*) + +Inductive cast8signed_cases: forall (e: expr), Type := + | cast8signed_case1: forall n, cast8signed_cases (Eop (Ointconst n) Enil) + | cast8signed_default: forall (e: expr), cast8signed_cases e. + +Definition cast8signed_match (e: expr) := + match e as zz1 return cast8signed_cases zz1 with + | Eop (Ointconst n) Enil => cast8signed_case1 n + | e => cast8signed_default e + end. + +Definition cast8signed (e: expr) := + match cast8signed_match e with + | cast8signed_case1 n => (* Eop (Ointconst n) Enil *) + Eop (Ointconst (Int.sign_ext 8 n)) Enil + | cast8signed_default e => + Eop Ocast8signed (e ::: Enil) + end. + + +(** Original definition: +<< +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. +>> +*) + +Inductive cast16unsigned_cases: forall (e: expr), Type := + | cast16unsigned_case1: forall n, cast16unsigned_cases (Eop (Ointconst n) Enil) + | cast16unsigned_case2: forall n t, cast16unsigned_cases (Eop (Oandimm n) (t:::Enil)) + | cast16unsigned_default: forall (e: expr), cast16unsigned_cases e. + +Definition cast16unsigned_match (e: expr) := + match e as zz1 return cast16unsigned_cases zz1 with + | Eop (Ointconst n) Enil => cast16unsigned_case1 n + | Eop (Oandimm n) (t:::Enil) => cast16unsigned_case2 n t + | e => cast16unsigned_default e + end. + +Definition cast16unsigned (e: expr) := + match cast16unsigned_match e with + | cast16unsigned_case1 n => (* Eop (Ointconst n) Enil *) + Eop (Ointconst (Int.zero_ext 16 n)) Enil + | cast16unsigned_case2 n t => (* Eop (Oandimm n) (t:::Enil) *) + andimm (Int.and (Int.repr 65535) n) t + | cast16unsigned_default e => + Eop Ocast16unsigned (e:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction cast16signed (e: expr) := + match e with + | Eop (Ointconst n) Enil => + Eop (Ointconst (Int.sign_ext 16 n)) Enil + | _ => + Eop Ocast16signed (e ::: Enil) + end. +>> +*) + +Inductive cast16signed_cases: forall (e: expr), Type := + | cast16signed_case1: forall n, cast16signed_cases (Eop (Ointconst n) Enil) + | cast16signed_default: forall (e: expr), cast16signed_cases e. + +Definition cast16signed_match (e: expr) := + match e as zz1 return cast16signed_cases zz1 with + | Eop (Ointconst n) Enil => cast16signed_case1 n + | e => cast16signed_default e + end. + +Definition cast16signed (e: expr) := + match cast16signed_match e with + | cast16signed_case1 n => (* Eop (Ointconst n) Enil *) + Eop (Ointconst (Int.sign_ext 16 n)) Enil + | cast16signed_default e => + Eop Ocast16signed (e ::: Enil) + end. + + +(** ** Selection *) + +Definition select_supported (ty: typ) : bool := + match ty with + | Tint => true + | Tlong => Archi.ptr64 + | _ => false + end. + +(** [Asmgen.mk_sel] cannot always handle the conditions that are + implemented as a "and" of two processor flags. However it can + handle the negation of those conditions, which are implemented + as an "or". So, for the risky conditions we just take their + negation and swap the two arguments of the [select]. *) + +Definition select_swap (cond: condition) := + match cond with + | Ccompf Cne | Ccompfs Cne | Cnotcompf Ceq | Cnotcompfs Ceq => true + | _ => false + end. + +Definition select (ty: typ) (cond: condition) (args: exprlist) (e1 e2: expr) := + if select_supported ty then + if select_swap cond + then Some (Eop (Osel (negate_condition cond) ty) (e2 ::: e1 ::: args)) + else Some (Eop (Osel cond ty) (e1 ::: e2 ::: args)) + else None. + +(** ** 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). + +(** Original definition: +<< +Nondetfunction floatofint (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_int n)) Enil + | _ => Eop Ofloatofint (e ::: Enil) + end. +>> +*) + +Inductive floatofint_cases: forall (e: expr), Type := + | floatofint_case1: forall n, floatofint_cases (Eop (Ointconst n) Enil) + | floatofint_default: forall (e: expr), floatofint_cases e. + +Definition floatofint_match (e: expr) := + match e as zz1 return floatofint_cases zz1 with + | Eop (Ointconst n) Enil => floatofint_case1 n + | e => floatofint_default e + end. + +Definition floatofint (e: expr) := + match floatofint_match e with + | floatofint_case1 n => (* Eop (Ointconst n) Enil *) + Eop (Ofloatconst (Float.of_int n)) Enil + | floatofint_default e => + Eop Ofloatofint (e ::: Enil) + end. + + +Definition intuoffloat (e: expr) := + if Archi.splitlong then + 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 + else + Eop Olowlong (Eop Olongoffloat (e ::: Enil) ::: Enil). + +(** Original definition: +<< +Nondetfunction floatofintu (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_intu n)) Enil + | _ => + if Archi.splitlong then + 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)) + else + Eop Ofloatoflong (Eop Ocast32unsigned (e ::: Enil) ::: Enil) + end. +>> +*) + +Inductive floatofintu_cases: forall (e: expr), Type := + | floatofintu_case1: forall n, floatofintu_cases (Eop (Ointconst n) Enil) + | floatofintu_default: forall (e: expr), floatofintu_cases e. + +Definition floatofintu_match (e: expr) := + match e as zz1 return floatofintu_cases zz1 with + | Eop (Ointconst n) Enil => floatofintu_case1 n + | e => floatofintu_default e + end. + +Definition floatofintu (e: expr) := + match floatofintu_match e with + | floatofintu_case1 n => (* Eop (Ointconst n) Enil *) + Eop (Ofloatconst (Float.of_intu n)) Enil + | floatofintu_default e => + if Archi.splitlong then 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)) else Eop Ofloatoflong (Eop Ocast32unsigned (e ::: Enil) ::: Enil) + end. + + +Definition intofsingle (e: expr) := Eop Ointofsingle (e ::: Enil). + +(** Original definition: +<< +Nondetfunction singleofint (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Osingleconst (Float32.of_int n)) Enil + | _ => Eop Osingleofint (e ::: Enil) + end. +>> +*) + +Inductive singleofint_cases: forall (e: expr), Type := + | singleofint_case1: forall n, singleofint_cases (Eop (Ointconst n) Enil) + | singleofint_default: forall (e: expr), singleofint_cases e. + +Definition singleofint_match (e: expr) := + match e as zz1 return singleofint_cases zz1 with + | Eop (Ointconst n) Enil => singleofint_case1 n + | e => singleofint_default e + end. + +Definition singleofint (e: expr) := + match singleofint_match e with + | singleofint_case1 n => (* Eop (Ointconst n) Enil *) + Eop (Osingleconst (Float32.of_int n)) Enil + | singleofint_default e => + Eop Osingleofint (e ::: Enil) + end. + + +Definition intuofsingle (e: expr) := intuoffloat (floatofsingle e). + +(** Original definition: +<< +Nondetfunction singleofintu (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Osingleconst (Float32.of_intu n)) Enil + | _ => singleoffloat (floatofintu e) + end. +>> +*) + +Inductive singleofintu_cases: forall (e: expr), Type := + | singleofintu_case1: forall n, singleofintu_cases (Eop (Ointconst n) Enil) + | singleofintu_default: forall (e: expr), singleofintu_cases e. + +Definition singleofintu_match (e: expr) := + match e as zz1 return singleofintu_cases zz1 with + | Eop (Ointconst n) Enil => singleofintu_case1 n + | e => singleofintu_default e + end. + +Definition singleofintu (e: expr) := + match singleofintu_match e with + | singleofintu_case1 n => (* Eop (Ointconst n) Enil *) + Eop (Osingleconst (Float32.of_intu n)) Enil + | singleofintu_default e => + singleoffloat (floatofintu e) + end. + + +(** ** Addressing modes *) + +(** Original definition: +<< +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. +>> +*) + +Inductive addressing_cases: forall (e: expr), Type := + | addressing_case1: forall addr args, addressing_cases (Eop (Olea addr) args) + | addressing_case2: forall addr args, addressing_cases (Eop (Oleal addr) args) + | addressing_default: forall (e: expr), addressing_cases e. + +Definition addressing_match (e: expr) := + match e as zz1 return addressing_cases zz1 with + | Eop (Olea addr) args => addressing_case1 addr args + | Eop (Oleal addr) args => addressing_case2 addr args + | e => addressing_default e + end. + +Definition addressing (chunk: memory_chunk) (e: expr) := + match addressing_match e with + | addressing_case1 addr args => (* Eop (Olea addr) args *) + if (negb Archi.ptr64) && addressing_valid addr then (addr, args) else (Aindexed 0, e:::Enil) + | addressing_case2 addr args => (* Eop (Oleal addr) args *) + if Archi.ptr64 && addressing_valid addr then (addr, args) else (Aindexed 0, e:::Enil) + | addressing_default e => + (Aindexed 0, e:::Enil) + end. + + +(** ** Arguments of builtins *) + +(** Original definition: +<< +Nondetfunction builtin_arg_addr (addr: Op.addressing) (el: exprlist) := + match addr, el with + | Aindexed n, e1 ::: Enil => + BA_addptr (BA e1) (if Archi.ptr64 then BA_long (Int64.repr n) else BA_int (Int.repr n)) + | Aglobal id ofs, Enil => BA_addrglobal id ofs + | Ainstack ofs, Enil => BA_addrstack ofs + | _, _ => BA (Eop (Olea_ptr addr) el) + end. +>> +*) + +Inductive builtin_arg_addr_cases: forall (addr: Op.addressing) (el: exprlist), Type := + | builtin_arg_addr_case1: forall n e1, builtin_arg_addr_cases (Aindexed n) (e1 ::: Enil) + | builtin_arg_addr_case2: forall id ofs, builtin_arg_addr_cases (Aglobal id ofs) (Enil) + | builtin_arg_addr_case3: forall ofs, builtin_arg_addr_cases (Ainstack ofs) (Enil) + | builtin_arg_addr_default: forall (addr: Op.addressing) (el: exprlist), builtin_arg_addr_cases addr el. + +Definition builtin_arg_addr_match (addr: Op.addressing) (el: exprlist) := + match addr as zz1, el as zz2 return builtin_arg_addr_cases zz1 zz2 with + | Aindexed n, e1 ::: Enil => builtin_arg_addr_case1 n e1 + | Aglobal id ofs, Enil => builtin_arg_addr_case2 id ofs + | Ainstack ofs, Enil => builtin_arg_addr_case3 ofs + | addr, el => builtin_arg_addr_default addr el + end. + +Definition builtin_arg_addr (addr: Op.addressing) (el: exprlist) := + match builtin_arg_addr_match addr el with + | builtin_arg_addr_case1 n e1 => (* Aindexed n, e1 ::: Enil *) + BA_addptr (BA e1) (if Archi.ptr64 then BA_long (Int64.repr n) else BA_int (Int.repr n)) + | builtin_arg_addr_case2 id ofs => (* Aglobal id ofs, Enil *) + BA_addrglobal id ofs + | builtin_arg_addr_case3 ofs => (* Ainstack ofs, Enil *) + BA_addrstack ofs + | builtin_arg_addr_default addr el => + BA (Eop (Olea_ptr addr) el) + end. + + +(** Original definition: +<< +Nondetfunction builtin_arg (e: expr) := + match e with + | Eop (Ointconst n) Enil => BA_int n + | Eop (Olongconst n) Enil => BA_long n + | Eop (Olea addr) el => + if Archi.ptr64 then BA e else builtin_arg_addr addr el + | Eop (Oleal addr) el => + if Archi.ptr64 then builtin_arg_addr addr el 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. +>> +*) + +Inductive builtin_arg_cases: forall (e: expr), Type := + | builtin_arg_case1: forall n, builtin_arg_cases (Eop (Ointconst n) Enil) + | builtin_arg_case2: forall n, builtin_arg_cases (Eop (Olongconst n) Enil) + | builtin_arg_case3: forall addr el, builtin_arg_cases (Eop (Olea addr) el) + | builtin_arg_case4: forall addr el, builtin_arg_cases (Eop (Oleal addr) el) + | builtin_arg_case5: forall h l, builtin_arg_cases (Eop Omakelong (Eop (Ointconst h) Enil ::: Eop (Ointconst l) Enil ::: Enil)) + | builtin_arg_case6: forall h l, builtin_arg_cases (Eop Omakelong (h ::: l ::: Enil)) + | builtin_arg_case7: forall chunk id ofs, builtin_arg_cases (Eload chunk (Aglobal id ofs) Enil) + | builtin_arg_case8: forall chunk ofs, builtin_arg_cases (Eload chunk (Ainstack ofs) Enil) + | builtin_arg_default: forall (e: expr), builtin_arg_cases e. + +Definition builtin_arg_match (e: expr) := + match e as zz1 return builtin_arg_cases zz1 with + | Eop (Ointconst n) Enil => builtin_arg_case1 n + | Eop (Olongconst n) Enil => builtin_arg_case2 n + | Eop (Olea addr) el => builtin_arg_case3 addr el + | Eop (Oleal addr) el => builtin_arg_case4 addr el + | Eop Omakelong (Eop (Ointconst h) Enil ::: Eop (Ointconst l) Enil ::: Enil) => builtin_arg_case5 h l + | Eop Omakelong (h ::: l ::: Enil) => builtin_arg_case6 h l + | Eload chunk (Aglobal id ofs) Enil => builtin_arg_case7 chunk id ofs + | Eload chunk (Ainstack ofs) Enil => builtin_arg_case8 chunk ofs + | e => builtin_arg_default e + end. + +Definition builtin_arg (e: expr) := + match builtin_arg_match e with + | builtin_arg_case1 n => (* Eop (Ointconst n) Enil *) + BA_int n + | builtin_arg_case2 n => (* Eop (Olongconst n) Enil *) + BA_long n + | builtin_arg_case3 addr el => (* Eop (Olea addr) el *) + if Archi.ptr64 then BA e else builtin_arg_addr addr el + | builtin_arg_case4 addr el => (* Eop (Oleal addr) el *) + if Archi.ptr64 then builtin_arg_addr addr el else BA e + | builtin_arg_case5 h l => (* Eop Omakelong (Eop (Ointconst h) Enil ::: Eop (Ointconst l) Enil ::: Enil) *) + BA_long (Int64.ofwords h l) + | builtin_arg_case6 h l => (* Eop Omakelong (h ::: l ::: Enil) *) + BA_splitlong (BA h) (BA l) + | builtin_arg_case7 chunk id ofs => (* Eload chunk (Aglobal id ofs) Enil *) + BA_loadglobal chunk id ofs + | builtin_arg_case8 chunk ofs => (* Eload chunk (Ainstack ofs) Enil *) + BA_loadstack chunk ofs + | builtin_arg_default e => + BA e + end. + + +(** Platform-specific known builtins *) + +Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr := + None. diff --git a/verilog/SelectOp.vp b/verilog/SelectOp.vp new file mode 100644 index 00000000..31be8c32 --- /dev/null +++ b/verilog/SelectOp.vp @@ -0,0 +1,582 @@ +(* *********************************************************************) +(* *) +(* 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 Builtins. +Require Import Op CminorSel. +Require Archi. + +Local Open 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. + +Definition mulhs (e1: expr) (e2: expr) := Eop Omulhs (e1 ::: e2 ::: Enil). +Definition mulhu (e1: expr) (e2: expr) := Eop Omulhu (e1 ::: e2 ::: Enil). + +(** ** 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. + +(** ** Selection *) + +Definition select_supported (ty: typ) : bool := + match ty with + | Tint => true + | Tlong => Archi.ptr64 + | _ => false + end. + +(** [Asmgen.mk_sel] cannot always handle the conditions that are + implemented as a "and" of two processor flags. However it can + handle the negation of those conditions, which are implemented + as an "or". So, for the risky conditions we just take their + negation and swap the two arguments of the [select]. *) + +Definition select_swap (cond: condition) := + match cond with + | Ccompf Cne | Ccompfs Cne | Cnotcompf Ceq | Cnotcompfs Ceq => true + | _ => false + end. + +Definition select (ty: typ) (cond: condition) (args: exprlist) (e1 e2: expr) := + if select_supported ty then + if select_swap cond + then Some (Eop (Osel (negate_condition cond) ty) (e2 ::: e1 ::: args)) + else Some (Eop (Osel cond ty) (e1 ::: e2 ::: args)) + else None. + +(** ** 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) := + if Archi.splitlong then + 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 + else + Eop Olowlong (Eop Olongoffloat (e ::: Enil) ::: Enil). + +Nondetfunction floatofintu (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_intu n)) Enil + | _ => + if Archi.splitlong then + 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)) + else + Eop Ofloatoflong (Eop Ocast32unsigned (e ::: Enil) ::: Enil) + 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_addr (addr: Op.addressing) (el: exprlist) := + match addr, el with + | Aindexed n, e1 ::: Enil => + BA_addptr (BA e1) (if Archi.ptr64 then BA_long (Int64.repr n) else BA_int (Int.repr n)) + | Aglobal id ofs, Enil => BA_addrglobal id ofs + | Ainstack ofs, Enil => BA_addrstack ofs + | _, _ => BA (Eop (Olea_ptr addr) el) + end. + +Nondetfunction builtin_arg (e: expr) := + match e with + | Eop (Ointconst n) Enil => BA_int n + | Eop (Olongconst n) Enil => BA_long n + | Eop (Olea addr) el => + if Archi.ptr64 then BA e else builtin_arg_addr addr el + | Eop (Oleal addr) el => + if Archi.ptr64 then builtin_arg_addr addr el 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. + +(** Platform-specific known builtins *) + +Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr := + None. diff --git a/verilog/SelectOpproof.v b/verilog/SelectOpproof.v new file mode 100644 index 00000000..961f602c --- /dev/null +++ b/verilog/SelectOpproof.v @@ -0,0 +1,1027 @@ +(* *********************************************************************) +(* *) +(* 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 Integers Floats. +Require Import Values Memory Builtins Globalenvs. +Require Import Cminor Op CminorSel. +Require Import SelectOp. + +Local Open 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_mulhs: binary_constructor_sound mulhs Val.mulhs. +Proof. + unfold mulhs; red; intros; TrivialExists. +Qed. + +Theorem eval_mulhu: binary_constructor_sound mulhu Val.mulhu. +Proof. + unfold mulhu; red; intros; 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. omega. +- rewrite Val.zero_ext_and. TrivialExists. rewrite Val.and_assoc. + rewrite Int.and_commut. auto. omega. +- 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. omega. + 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. omega. + TrivialExists. +Qed. + +Theorem eval_select: + forall le ty cond al vl a1 v1 a2 v2 a b, + select ty cond al a1 a2 = Some a -> + eval_exprlist ge sp e m le al vl -> + eval_expr ge sp e m le a1 v1 -> + eval_expr ge sp e m le a2 v2 -> + eval_condition cond vl m = Some b -> + exists v, + eval_expr ge sp e m le a v + /\ Val.lessdef (Val.select (Some b) v1 v2 ty) v. +Proof. + unfold select; intros. + destruct (select_supported ty); try discriminate. + destruct (select_swap cond); inv H. +- exists (Val.select (Some (negb b)) v2 v1 ty); split. + apply eval_Eop with (v2 :: v1 :: vl). + constructor; auto. constructor; auto. + simpl. rewrite eval_negate_condition, H3; auto. + destruct b; auto. +- exists (Val.select (Some b) v1 v2 ty); split. + apply eval_Eop with (v1 :: v2 :: vl). + constructor; auto. constructor; auto. + simpl. rewrite H3; auto. + auto. +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. + destruct Archi.splitlong. +- 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. +- apply Float.to_intu_to_long in Heqo. repeat econstructor. eauto. + simpl. rewrite Heqo; reflexivity. + simpl. unfold Int64.loword. rewrite Int64.unsigned_repr, Int.repr_unsigned; auto. + assert (Int.modulus < Int64.max_unsigned) by reflexivity. + generalize (Int.unsigned_range n); omega. +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. + destruct Archi.splitlong. ++ 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. ++ rewrite Float.of_intu_of_long. repeat econstructor. eauto. reflexivity. +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_addr: + forall addr al vl v, + eval_exprlist ge sp e m nil al vl -> + Op.eval_addressing ge sp addr vl = Some v -> + CminorSel.eval_builtin_arg ge sp e m (builtin_arg_addr addr al) v. +Proof. + intros until v. unfold builtin_arg_addr; case (builtin_arg_addr_match addr al); intros; InvEval. +- set (v2 := if Archi.ptr64 then Vlong (Int64.repr n) else Vint (Int.repr n)). + assert (EQ: v = if Archi.ptr64 then Val.addl v1 v2 else Val.add v1 v2). + { unfold Op.eval_addressing in H0; unfold v2; destruct Archi.ptr64; simpl in H0; inv H0; auto. } + rewrite EQ. constructor. constructor; auto. unfold v2; destruct Archi.ptr64; constructor. +- rewrite eval_addressing_Aglobal in H0. inv H0. constructor. +- rewrite eval_addressing_Ainstack in H0. inv H0. constructor. +- constructor. econstructor. eauto. rewrite eval_Olea_ptr. 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. +- destruct Archi.ptr64 eqn:SF. ++ constructor; auto. ++ inv H. eapply eval_builtin_arg_addr. eauto. unfold Op.eval_addressing; rewrite SF; assumption. +- destruct Archi.ptr64 eqn:SF. ++ inv H. eapply eval_builtin_arg_addr. eauto. unfold Op.eval_addressing; rewrite SF; assumption. ++ constructor; auto. +- 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. + +(** Platform-specific known builtins *) + +Theorem eval_platform_builtin: + forall bf al a vl v le, + platform_builtin bf al = Some a -> + eval_exprlist ge sp e m le al vl -> + platform_builtin_sem bf vl = Some v -> + exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'. +Proof. + intros. discriminate. +Qed. + +End CMCONSTR. diff --git a/verilog/Stacklayout.v b/verilog/Stacklayout.v new file mode 100644 index 00000000..d375febf --- /dev/null +++ b/verilog/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 Z.divide_0_r. + split. apply align_divides; omega. + split. apply align_divides; omega. + split. apply align_divides; omega. + apply align_divides; omega. +Qed. diff --git a/verilog/TargetPrinter.ml b/verilog/TargetPrinter.ml new file mode 100644 index 00000000..f0a54506 --- /dev/null +++ b/verilog/TargetPrinter.ml @@ -0,0 +1,925 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(* Printing x86-64 assembly code in asm syntax *) + +open Printf +open Camlcoq +open Sections +open AST +open Asm +open AisAnnot +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_asm oc ty = function + | IR r -> if ty = Tlong then ireg64 oc r else ireg32 oc r + | FR r -> freg oc r + | _ -> assert false + +let preg_annot = function + | IR r -> if Archi.ptr64 then int64_reg_name r else int32_reg_name r + | FR r -> float_reg_name r + | _ -> assert false + +let ais_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 ais_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 preg_ais_annot = function + | IR r -> if Archi.ptr64 then ais_int64_reg_name r else ais_int32_reg_name r + | FR r -> float_reg_name 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 = "#" + +(* 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) + +(* System dependent 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 common_section () + | Section_const i | Section_small_const i -> + if i || (not !Clflags.option_fcommon) 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" + | Section_ais_annotation -> sprintf ".section \"__compcert_ais_annotations\",\"\",@note" + + 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 || (not !Clflags.option_fcommon) then ".data" else "COMM" + | Section_const i | Section_small_const i -> + if i || (not !Clflags.option_fcommon) then ".const" else "COMM" + | Section_string -> ".const" + | Section_literal -> ".literal8" + | Section_jumptable -> ".text" + | 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" + | Section_ais_annotation -> assert false (* Not supported under MacOS *) + + + let stack_alignment = 16 (* mandatory *) + + let print_align oc n = + fprintf oc " .align %d\n" (log2 n) + + let print_mov_rs oc rd id = + fprintf oc " movq %a@GOTPCREL(%%rip), %a\n" symbol id ireg64 rd + + let print_fun_info _ _ = () + + let print_var_info _ _ = () + + let print_epilogue oc = () + + 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 + +(* Printer functions for Cygwin *) +module Cygwin_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 common_section () + | Section_const i | Section_small_const i -> + if i || (not !Clflags.option_fcommon) then ".section .rdata,\"dr\"" else "COMM" + | Section_string -> ".section .rdata,\"dr\"" + | Section_literal -> ".section .rdata,\"dr\"" + | Section_jumptable -> ".text" + | Section_user(s, wr, ex) -> + sprintf ".section %s, \"%s\"\n" + s (if ex then "xr" else if wr then "d" else "dr") + | Section_debug_info _ -> ".section .debug_info,\"dr\"" + | Section_debug_loc -> ".section .debug_loc,\"dr\"" + | Section_debug_line _ -> ".section .debug_line,\"dr\"" + | Section_debug_abbrev -> ".section .debug_abbrev,\"dr\"" + | Section_debug_ranges -> ".section .debug_ranges,\"dr\"" + | Section_debug_str-> assert false (* Should not be used *) + | Section_ais_annotation -> assert false (* Not supported for coff binaries *) + + let stack_alignment = 8 (* minimum is 4, 8 is better for perfs *) + + let print_align oc n = + fprintf oc " .balign %d\n" n + + let print_mov_rs oc rd id = + fprintf oc " movl $%a, %a\n" symbol id ireg rd + + let print_fun_info _ _ = () + + let 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) (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 addressing_gen ireg oc (Addrmode(base, shift, cst)) = + begin match cst with + | Datatypes.Coq_inl n -> + fprintf oc "%s" (Z.to_string n) + | Datatypes.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 = label_literal64 n1 in + fprintf oc "%a(%%rip)" label lbl + end + + + +(* Printing of instructions *) + +(* Reminder on X86 assembly syntaxes: + AT&T syntax Intel syntax + (used by GNU as) (used in reference manuals) + dst <- op(src) op src, dst op dst, src + dst <- op(dst, src2) op src2, dst op dst, src2 + dst <- op(dst, src2, src3) op src3, src2, dst op dst, src2, src3 +*) + + 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 = label_literal64 b in + fprintf oc " movsd %a%s, %a %s %.18g\n" + label lbl rip_rel + freg rd comment (camlfloat_of_coqfloat n) + | 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 = label_literal32 b in + fprintf oc " movss %a%s, %a %s %.18g\n" + label lbl rip_rel + freg rd comment (camlfloat_of_coqfloat32 n) + | 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 a2 freg a1 freg res + | Pfmadd213 (res,a1,a2) -> + fprintf oc " vfmadd213sd %a, %a, %a\n" freg a2 freg a1 freg res + | Pfmadd231 (res,a1,a2) -> + fprintf oc " vfmadd231sd %a, %a, %a\n" freg a2 freg a1 freg res + | Pfmsub132 (res,a1,a2) -> + fprintf oc " vfmsub132sd %a, %a, %a\n" freg a2 freg a1 freg res + | Pfmsub213 (res,a1,a2) -> + fprintf oc " vfmsub213sd %a, %a, %a\n" freg a2 freg a1 freg res + | Pfmsub231 (res,a1,a2) -> + fprintf oc " vfmsub231sd %a, %a, %a\n" freg a2 freg a1 freg res + | Pfnmadd132 (res,a1,a2) -> + fprintf oc " vfnmadd132sd %a, %a, %a\n" freg a2 freg a1 freg res + | Pfnmadd213 (res,a1,a2) -> + fprintf oc " vfnmadd213sd %a, %a, %a\n" freg a2 freg a1 freg res + | Pfnmadd231 (res,a1,a2) -> + fprintf oc " vfnmadd231sd %a, %a, %a\n" freg a2 freg a1 freg res + | Pfnmsub132 (res,a1,a2) -> + fprintf oc " vfnmsub132sd %a, %a, %a\n" freg a2 freg a1 freg res + | Pfnmsub213 (res,a1,a2) -> + fprintf oc " vfnmsub213sd %a, %a, %a\n" freg a2 freg a1 freg res + | Pfnmsub231 (res,a1,a2) -> + fprintf oc " vfnmsub231sd %a, %a, %a\n" freg a2 freg a1 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 + | Pnop -> + fprintf oc " nop\n" + | 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(kind,txt, targs) -> + begin match (P.to_int kind) with + | 1 -> let annot = annot_text preg_annot "esp" (camlstring_of_coqstring txt) args in + fprintf oc "%s annotation: %S\n" comment annot + | 2 -> let lbl = new_label () in + fprintf oc "%a:\n" label lbl; + let sp = if Archi.ptr64 then "rsp" else "esp" in + add_ais_annot lbl preg_ais_annot sp (camlstring_of_coqstring txt) args + | _ -> assert false + end + | EF_debug(kind, txt, targs) -> + print_debug_info comment print_file_line preg_annot "%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_asm oc (camlstring_of_coqstring txt) sg args res; + fprintf oc "%s end inline assembly\n" comment + | _ -> + assert false + end + + let print_literal64 oc n lbl = + fprintf oc "%a: .quad 0x%Lx\n" label lbl n + let print_literal32 oc n lbl = + 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_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 exists_constants () then begin + section oc lit; + print_align oc 8; + Hashtbl.iter (print_literal64 oc) literal64_labels; + Hashtbl.iter (print_literal32 oc) literal32_labels; + reset_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 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 address = if Archi.ptr64 then ".quad" else ".long" + +end + +let sel_target () = + let module S = (val (match Configuration.system with + | "linux" | "bsd" -> (module ELF_System:SYSTEM) + | "macosx" -> (module MacOS_System:SYSTEM) + | "cygwin" -> (module Cygwin_System:SYSTEM) + | _ -> invalid_arg ("System " ^ Configuration.system ^ " not supported") ):SYSTEM) in + (module Target(S):TARGET) diff --git a/verilog/ValueAOp.v b/verilog/ValueAOp.v new file mode 100644 index 00000000..d0b8427a --- /dev/null +++ b/verilog/ValueAOp.v @@ -0,0 +1,266 @@ +(* *********************************************************************) +(* *) +(* 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) + | Osel c ty, v1::v2::vl => select (eval_static_condition c vl) v1 v2 + | _, _ => 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. + apply select_sound; auto. eapply eval_static_condition_sound; eauto. +Qed. + +End SOUNDNESS. + diff --git a/verilog/extractionMachdep.v b/verilog/extractionMachdep.v new file mode 100644 index 00000000..a29553e8 --- /dev/null +++ b/verilog/extractionMachdep.v @@ -0,0 +1,29 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(* 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". + |