diff options
Diffstat (limited to 'ia32')
-rw-r--r-- | ia32/Archi.v | 54 | ||||
-rw-r--r-- | ia32/Asm.v | 1204 | ||||
-rw-r--r-- | ia32/AsmToJSON.ml | 17 | ||||
-rw-r--r-- | ia32/AsmToJSON.mli | 13 | ||||
-rw-r--r-- | ia32/Asmexpand.ml | 638 | ||||
-rw-r--r-- | ia32/Asmgen.v | 754 | ||||
-rw-r--r-- | ia32/Asmgenproof.v | 916 | ||||
-rw-r--r-- | ia32/Asmgenproof1.v | 1481 | ||||
-rw-r--r-- | ia32/CBuiltins.ml | 94 | ||||
-rw-r--r-- | ia32/CombineOp.v | 150 | ||||
-rw-r--r-- | ia32/CombineOpproof.v | 179 | ||||
-rw-r--r-- | ia32/ConstpropOp.vp | 404 | ||||
-rw-r--r-- | ia32/ConstpropOpproof.v | 881 | ||||
-rw-r--r-- | ia32/Conventions1.v | 473 | ||||
-rw-r--r-- | ia32/Machregs.v | 367 | ||||
-rw-r--r-- | ia32/Machregsaux.ml | 33 | ||||
-rw-r--r-- | ia32/Machregsaux.mli | 18 | ||||
-rw-r--r-- | ia32/NeedOp.v | 254 | ||||
-rw-r--r-- | ia32/Op.v | 1457 | ||||
-rw-r--r-- | ia32/PrintOp.ml | 169 | ||||
-rw-r--r-- | ia32/SelectLong.vp | 347 | ||||
-rw-r--r-- | ia32/SelectLongproof.v | 557 | ||||
-rw-r--r-- | ia32/SelectOp.vp | 530 | ||||
-rw-r--r-- | ia32/SelectOpproof.v | 958 | ||||
-rw-r--r-- | ia32/Stacklayout.v | 148 | ||||
-rw-r--r-- | ia32/TargetPrinter.ml | 881 | ||||
-rw-r--r-- | ia32/ValueAOp.v | 266 | ||||
-rw-r--r-- | ia32/extractionMachdep.v | 31 |
28 files changed, 0 insertions, 13274 deletions
diff --git a/ia32/Archi.v b/ia32/Archi.v deleted file mode 100644 index 936bacb3..00000000 --- a/ia32/Archi.v +++ /dev/null @@ -1,54 +0,0 @@ -(* *********************************************************************) -(* *) -(* 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 IA32 *) - -Require Import ZArith. -Require Import Fappli_IEEE. -Require Import Fappli_IEEE_bits. - -Parameter ptr64: bool. - -Definition big_endian := false. - -Definition align_int64 := if ptr64 then 8%Z else 4%Z. -Definition align_float64 := if ptr64 then 8%Z else 4%Z. - -Definition splitlong := negb ptr64. - -Lemma splitlong_ptr32: splitlong = true -> ptr64 = false. -Proof. - unfold splitlong. destruct ptr64; simpl; congruence. -Qed. - -Program Definition default_pl_64 : bool * nan_pl 53 := - (true, iter_nat 51 _ xO xH). - -Definition choose_binop_pl_64 (s1: bool) (pl1: nan_pl 53) (s2: bool) (pl2: nan_pl 53) := - false. (**r always choose first NaN *) - -Program Definition default_pl_32 : bool * nan_pl 24 := - (true, iter_nat 22 _ xO xH). - -Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_pl 24) := - false. (**r always choose first NaN *) - -Definition float_of_single_preserves_sNaN := false. - -Global Opaque ptr64 big_endian splitlong - default_pl_64 choose_binop_pl_64 - default_pl_32 choose_binop_pl_32 - float_of_single_preserves_sNaN. diff --git a/ia32/Asm.v b/ia32/Asm.v deleted file mode 100644 index 304cb8e4..00000000 --- a/ia32/Asm.v +++ /dev/null @@ -1,1204 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Abstract syntax and semantics for IA32 assembly language *) - -Require Import Coqlib Maps. -Require Import AST Integers Floats Values Memory Events Globalenvs Smallstep. -Require Import Locations Stacklayout Conventions. - -(** * Abstract syntax *) - -(** ** Registers. *) - -(** Integer registers. *) - -Inductive ireg: Type := - | RAX | RBX | RCX | RDX | RSI | RDI | RBP | RSP - | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15. - -(** Floating-point registers, i.e. SSE2 registers *) - -Inductive freg: Type := - | XMM0 | XMM1 | XMM2 | XMM3 | XMM4 | XMM5 | XMM6 | XMM7 - | XMM8 | XMM9 | XMM10 | XMM11 | XMM12 | XMM13 | XMM14 | XMM15. - -Lemma ireg_eq: forall (x y: ireg), {x=y} + {x<>y}. -Proof. decide equality. Defined. - -Lemma freg_eq: forall (x y: freg), {x=y} + {x<>y}. -Proof. decide equality. Defined. - -(** Bits of the flags register. *) - -Inductive crbit: Type := - | ZF | CF | PF | SF | OF. - -(** All registers modeled here. *) - -Inductive preg: Type := - | PC: preg (**r program counter *) - | IR: ireg -> preg (**r integer register *) - | FR: freg -> preg (**r XMM register *) - | ST0: preg (**r top of FP stack *) - | CR: crbit -> preg (**r bit of the flags register *) - | RA: preg. (**r pseudo-reg representing return address *) - -Coercion IR: ireg >-> preg. -Coercion FR: freg >-> preg. -Coercion CR: crbit >-> preg. - -(** Conventional names for stack pointer ([SP]) and return address ([RA]) *) - -Notation SP := RSP (only parsing). - -(** ** Instruction set. *) - -Definition label := positive. - -(** General form of an addressing mode. *) - -Inductive addrmode: Type := - | Addrmode (base: option ireg) - (ofs: option (ireg * Z)) - (const: Z + ident * ptrofs). - -(** Testable conditions (for conditional jumps and more). *) - -Inductive testcond: Type := - | Cond_e | Cond_ne - | Cond_b | Cond_be | Cond_ae | Cond_a - | Cond_l | Cond_le | Cond_ge | Cond_g - | Cond_p | Cond_np. - -(** Instructions. IA32 instructions accept many combinations of - registers, memory references and immediate constants as arguments. - Here, we list only the combinations that we actually use. - - Naming conventions for types: -- [b]: 8 bits -- [w]: 16 bits ("word") -- [l]: 32 bits ("longword") -- [q]: 64 bits ("quadword") -- [d] or [sd]: FP double precision (64 bits) -- [s] or [ss]: FP single precision (32 bits) - - Naming conventions for operands: -- [r]: integer register operand -- [f]: XMM register operand -- [m]: memory operand -- [i]: immediate integer operand -- [s]: immediate symbol operand -- [l]: immediate label operand -- [cl]: the [CL] register - - For two-operand instructions, the first suffix describes the result - (and first argument), the second suffix describes the second argument. -*) - -Inductive instruction: Type := - (** Moves *) - | Pmov_rr (rd: ireg) (r1: ireg) (**r [mov] (integer) *) - | Pmovl_ri (rd: ireg) (n: int) - | Pmovq_ri (rd: ireg) (n: int64) - | Pmov_rs (rd: ireg) (id: ident) - | Pmovl_rm (rd: ireg) (a: addrmode) - | Pmovq_rm (rd: ireg) (a: addrmode) - | Pmovl_mr (a: addrmode) (rs: ireg) - | Pmovq_mr (a: addrmode) (rs: ireg) - | Pmovsd_ff (rd: freg) (r1: freg) (**r [movsd] (single 64-bit float) *) - | Pmovsd_fi (rd: freg) (n: float) (**r (pseudo-instruction) *) - | Pmovsd_fm (rd: freg) (a: addrmode) - | Pmovsd_mf (a: addrmode) (r1: freg) - | Pmovss_fi (rd: freg) (n: float32) (**r [movss] (single 32-bit float) *) - | Pmovss_fm (rd: freg) (a: addrmode) - | Pmovss_mf (a: addrmode) (r1: freg) - | Pfldl_m (a: addrmode) (**r [fld] double precision *) - | Pfstpl_m (a: addrmode) (**r [fstp] double precision *) - | Pflds_m (a: addrmode) (**r [fld] simple precision *) - | Pfstps_m (a: addrmode) (**r [fstp] simple precision *) - (** Moves with conversion *) - | Pmovb_mr (a: addrmode) (rs: ireg) (**r [mov] (8-bit int) *) - | Pmovw_mr (a: addrmode) (rs: ireg) (**r [mov] (16-bit int) *) - | Pmovzb_rr (rd: ireg) (rs: ireg) (**r [movzb] (8-bit zero-extension) *) - | Pmovzb_rm (rd: ireg) (a: addrmode) - | Pmovsb_rr (rd: ireg) (rs: ireg) (**r [movsb] (8-bit sign-extension) *) - | Pmovsb_rm (rd: ireg) (a: addrmode) - | Pmovzw_rr (rd: ireg) (rs: ireg) (**r [movzw] (16-bit zero-extension) *) - | Pmovzw_rm (rd: ireg) (a: addrmode) - | Pmovsw_rr (rd: ireg) (rs: ireg) (**r [movsw] (16-bit sign-extension) *) - | Pmovsw_rm (rd: ireg) (a: addrmode) - | Pmovzl_rr (rd: ireg) (rs: ireg) (**r [movzl] (32-bit zero-extension) *) - | Pmovsl_rr (rd: ireg) (rs: ireg) (**r [movsl] (32-bit sign-extension) *) - | Pmovls_rr (rd: ireg) (** 64 to 32 bit conversion (pseudo) *) - | Pcvtsd2ss_ff (rd: freg) (r1: freg) (**r conversion to single float *) - | Pcvtss2sd_ff (rd: freg) (r1: freg) (**r conversion to double float *) - | Pcvttsd2si_rf (rd: ireg) (r1: freg) (**r double to signed int *) - | Pcvtsi2sd_fr (rd: freg) (r1: ireg) (**r signed int to double *) - | Pcvttss2si_rf (rd: ireg) (r1: freg) (**r single to signed int *) - | Pcvtsi2ss_fr (rd: freg) (r1: ireg) (**r signed int to single *) - | Pcvttsd2sl_rf (rd: ireg) (r1: freg) (**r double to signed long *) - | Pcvtsl2sd_fr (rd: freg) (r1: ireg) (**r signed long to double *) - | Pcvttss2sl_rf (rd: ireg) (r1: freg) (**r single to signed long *) - | Pcvtsl2ss_fr (rd: freg) (r1: ireg) (**r signed long to single *) - (** Integer arithmetic *) - | Pleal (rd: ireg) (a: addrmode) - | Pleaq (rd: ireg) (a: addrmode) - | Pnegl (rd: ireg) - | Pnegq (rd: ireg) - | Paddl_ri (rd: ireg) (n: int) - | Paddq_ri (rd: ireg) (n: int64) - | Psubl_rr (rd: ireg) (r1: ireg) - | Psubq_rr (rd: ireg) (r1: ireg) - | Pimull_rr (rd: ireg) (r1: ireg) - | Pimulq_rr (rd: ireg) (r1: ireg) - | Pimull_ri (rd: ireg) (n: int) - | Pimulq_ri (rd: ireg) (n: int64) - | Pimull_r (r1: ireg) - | Pimulq_r (r1: ireg) - | Pmull_r (r1: ireg) - | Pmulq_r (r1: ireg) - | Pcltd - | Pcqto - | Pdivl (r1: ireg) - | Pdivq (r1: ireg) - | Pidivl (r1: ireg) - | Pidivq (r1: ireg) - | Pandl_rr (rd: ireg) (r1: ireg) - | Pandq_rr (rd: ireg) (r1: ireg) - | Pandl_ri (rd: ireg) (n: int) - | Pandq_ri (rd: ireg) (n: int64) - | Porl_rr (rd: ireg) (r1: ireg) - | Porq_rr (rd: ireg) (r1: ireg) - | Porl_ri (rd: ireg) (n: int) - | Porq_ri (rd: ireg) (n: int64) - | Pxorl_r (rd: ireg) (**r [xor] with self = set to zero *) - | Pxorq_r (rd: ireg) - | Pxorl_rr (rd: ireg) (r1: ireg) - | Pxorq_rr (rd: ireg) (r1: ireg) - | Pxorl_ri (rd: ireg) (n: int) - | Pxorq_ri (rd: ireg) (n: int64) - | Pnotl (rd: ireg) - | Pnotq (rd: ireg) - | Psall_rcl (rd: ireg) - | Psalq_rcl (rd: ireg) - | Psall_ri (rd: ireg) (n: int) - | Psalq_ri (rd: ireg) (n: int) - | Pshrl_rcl (rd: ireg) - | Pshrq_rcl (rd: ireg) - | Pshrl_ri (rd: ireg) (n: int) - | Pshrq_ri (rd: ireg) (n: int) - | Psarl_rcl (rd: ireg) - | Psarq_rcl (rd: ireg) - | Psarl_ri (rd: ireg) (n: int) - | Psarq_ri (rd: ireg) (n: int) - | Pshld_ri (rd: ireg) (r1: ireg) (n: int) - | Prorl_ri (rd: ireg) (n: int) - | Prorq_ri (rd: ireg) (n: int) - | Pcmpl_rr (r1 r2: ireg) - | Pcmpq_rr (r1 r2: ireg) - | Pcmpl_ri (r1: ireg) (n: int) - | Pcmpq_ri (r1: ireg) (n: int64) - | Ptestl_rr (r1 r2: ireg) - | Ptestq_rr (r1 r2: ireg) - | Ptestl_ri (r1: ireg) (n: int) - | Ptestq_ri (r1: ireg) (n: int64) - | Pcmov (c: testcond) (rd: ireg) (r1: ireg) - | Psetcc (c: testcond) (rd: ireg) - (** Floating-point arithmetic *) - | Paddd_ff (rd: freg) (r1: freg) - | Psubd_ff (rd: freg) (r1: freg) - | Pmuld_ff (rd: freg) (r1: freg) - | Pdivd_ff (rd: freg) (r1: freg) - | Pnegd (rd: freg) - | Pabsd (rd: freg) - | Pcomisd_ff (r1 r2: freg) - | Pxorpd_f (rd: freg) (**r [xor] with self = set to zero *) - | Padds_ff (rd: freg) (r1: freg) - | Psubs_ff (rd: freg) (r1: freg) - | Pmuls_ff (rd: freg) (r1: freg) - | Pdivs_ff (rd: freg) (r1: freg) - | Pnegs (rd: freg) - | Pabss (rd: freg) - | Pcomiss_ff (r1 r2: freg) - | Pxorps_f (rd: freg) (**r [xor] with self = set to zero *) - (** Branches and calls *) - | Pjmp_l (l: label) - | Pjmp_s (symb: ident) (sg: signature) - | Pjmp_r (r: ireg) (sg: signature) - | Pjcc (c: testcond)(l: label) - | Pjcc2 (c1 c2: testcond)(l: label) (**r pseudo *) - | Pjmptbl (r: ireg) (tbl: list label) (**r pseudo *) - | Pcall_s (symb: ident) (sg: signature) - | Pcall_r (r: ireg) (sg: signature) - | Pret - (** Saving and restoring registers *) - | Pmov_rm_a (rd: ireg) (a: addrmode) (**r like [Pmov_rm], using [Many64] chunk *) - | Pmov_mr_a (a: addrmode) (rs: ireg) (**r like [Pmov_mr], using [Many64] chunk *) - | Pmovsd_fm_a (rd: freg) (a: addrmode) (**r like [Pmovsd_fm], using [Many64] chunk *) - | Pmovsd_mf_a (a: addrmode) (r1: freg) (**r like [Pmovsd_mf], using [Many64] chunk *) - (** Pseudo-instructions *) - | Plabel(l: label) - | Pallocframe(sz: Z)(ofs_ra ofs_link: ptrofs) - | Pfreeframe(sz: Z)(ofs_ra ofs_link: ptrofs) - | Pbuiltin(ef: external_function)(args: list (builtin_arg preg))(res: builtin_res preg) - (** Instructions not generated by [Asmgen] -- TO CHECK *) - | Padcl_ri (rd: ireg) (n: int) - | Padcl_rr (rd: ireg) (r2: ireg) - | Paddl_mi (a: addrmode) (n: int) - | Paddl_rr (rd: ireg) (r2: ireg) - | Pbsfl (rd: ireg) (r1: ireg) - | Pbsfq (rd: ireg) (r1: ireg) - | Pbsrl (rd: ireg) (r1: ireg) - | Pbsrq (rd: ireg) (r1: ireg) - | Pbswap64 (rd: ireg) - | Pbswap32 (rd: ireg) - | Pbswap16 (rd: ireg) - | Pcfi_adjust (n: int) - | Pfmadd132 (rd: freg) (r2: freg) (r3: freg) - | Pfmadd213 (rd: freg) (r2: freg) (r3: freg) - | Pfmadd231 (rd: freg) (r2: freg) (r3: freg) - | Pfmsub132 (rd: freg) (r2: freg) (r3: freg) - | Pfmsub213 (rd: freg) (r2: freg) (r3: freg) - | Pfmsub231 (rd: freg) (r2: freg) (r3: freg) - | Pfnmadd132 (rd: freg) (r2: freg) (r3: freg) - | Pfnmadd213 (rd: freg) (r2: freg) (r3: freg) - | Pfnmadd231 (rd: freg) (r2: freg) (r3: freg) - | Pfnmsub132 (rd: freg) (r2: freg) (r3: freg) - | Pfnmsub213 (rd: freg) (r2: freg) (r3: freg) - | Pfnmsub231 (rd: freg) (r2: freg) (r3: freg) - | Pmaxsd (rd: freg) (r2: freg) - | Pminsd (rd: freg) (r2: freg) - | Pmovb_rm (rd: ireg) (a: addrmode) - | Pmovsq_mr (a: addrmode) (rs: freg) - | Pmovsq_rm (rd: freg) (a: addrmode) - | Pmovsb - | Pmovsw - | Pmovw_rm (rd: ireg) (ad: addrmode) - | Prep_movsl - | Psbbl_rr (rd: ireg) (r2: ireg) - | Psqrtsd (rd: freg) (r1: freg) - | Psubl_ri (rd: ireg) (n: int) - | Psubq_ri (rd: ireg) (n: int64). - -Definition code := list instruction. -Record function : Type := mkfunction { fn_sig: signature; fn_code: code }. -Definition fundef := AST.fundef function. -Definition program := AST.program fundef unit. - -(** * Operational semantics *) - -Lemma preg_eq: forall (x y: preg), {x=y} + {x<>y}. -Proof. decide equality. apply ireg_eq. apply freg_eq. decide equality. Defined. - -Module PregEq. - Definition t := preg. - Definition eq := preg_eq. -End PregEq. - -Module Pregmap := EMap(PregEq). - -Definition regset := Pregmap.t val. -Definition genv := Genv.t fundef unit. - -Notation "a # b" := (a b) (at level 1, only parsing). -Notation "a # b <- c" := (Pregmap.set b c a) (at level 1, b at next level). - -(** Undefining some registers *) - -Fixpoint undef_regs (l: list preg) (rs: regset) : regset := - match l with - | nil => rs - | r :: l' => undef_regs l' (rs#r <- Vundef) - end. - -(** Assigning a register pair *) - -Definition set_pair (p: rpair preg) (v: val) (rs: regset) : regset := - match p with - | One r => rs#r <- v - | Twolong rhi rlo => rs#rhi <- (Val.hiword v) #rlo <- (Val.loword v) - end. - -(** Assigning the result of a builtin *) - -Fixpoint set_res (res: builtin_res preg) (v: val) (rs: regset) : regset := - match res with - | BR r => rs#r <- v - | BR_none => rs - | BR_splitlong hi lo => set_res lo (Val.loword v) (set_res hi (Val.hiword v) rs) - end. - -Section RELSEM. - -(** Looking up instructions in a code sequence by position. *) - -Fixpoint find_instr (pos: Z) (c: code) {struct c} : option instruction := - match c with - | nil => None - | i :: il => if zeq pos 0 then Some i else find_instr (pos - 1) il - end. - -(** Position corresponding to a label *) - -Definition is_label (lbl: label) (instr: instruction) : bool := - match instr with - | Plabel lbl' => if peq lbl lbl' then true else false - | _ => false - end. - -Lemma is_label_correct: - forall lbl instr, - if is_label lbl instr then instr = Plabel lbl else instr <> Plabel lbl. -Proof. - intros. destruct instr; simpl; try discriminate. - case (peq lbl l); intro; congruence. -Qed. - -Fixpoint label_pos (lbl: label) (pos: Z) (c: code) {struct c} : option Z := - match c with - | nil => None - | instr :: c' => - if is_label lbl instr then Some (pos + 1) else label_pos lbl (pos + 1) c' - end. - -Variable ge: genv. - -(** Evaluating an addressing mode *) - -Definition eval_addrmode32 (a: addrmode) (rs: regset) : val := - let '(Addrmode base ofs const) := a in - Val.add (match base with - | None => Vint Int.zero - | Some r => rs r - end) - (Val.add (match ofs with - | None => Vint Int.zero - | Some(r, sc) => - if zeq sc 1 - then rs r - else Val.mul (rs r) (Vint (Int.repr sc)) - end) - (match const with - | inl ofs => Vint (Int.repr ofs) - | inr(id, ofs) => Genv.symbol_address ge id ofs - end)). - -Definition eval_addrmode64 (a: addrmode) (rs: regset) : val := - let '(Addrmode base ofs const) := a in - Val.addl (match base with - | None => Vlong Int64.zero - | Some r => rs r - end) - (Val.addl (match ofs with - | None => Vlong Int64.zero - | Some(r, sc) => - if zeq sc 1 - then rs r - else Val.mull (rs r) (Vlong (Int64.repr sc)) - end) - (match const with - | inl ofs => Vlong (Int64.repr ofs) - | inr(id, ofs) => Genv.symbol_address ge id ofs - end)). - -Definition eval_addrmode (a: addrmode) (rs: regset) : val := - if Archi.ptr64 then eval_addrmode64 a rs else eval_addrmode32 a rs. - -(** Performing a comparison *) - -(** Integer comparison between x and y: -- ZF = 1 if x = y, 0 if x != y -- CF = 1 if x <u y, 0 if x >=u y -- SF = 1 if x - y is negative, 0 if x - y is positive -- OF = 1 if x - y overflows (signed), 0 if not -- PF is undefined -*) - -Definition compare_ints (x y: val) (rs: regset) (m: mem): regset := - rs #ZF <- (Val.cmpu (Mem.valid_pointer m) Ceq x y) - #CF <- (Val.cmpu (Mem.valid_pointer m) Clt x y) - #SF <- (Val.negative (Val.sub x y)) - #OF <- (Val.sub_overflow x y) - #PF <- Vundef. - -Definition compare_longs (x y: val) (rs: regset) (m: mem): regset := - rs #ZF <- (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Ceq x y)) - #CF <- (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Clt x y)) - #SF <- (Val.negativel (Val.subl x y)) - #OF <- (Val.subl_overflow x y) - #PF <- Vundef. - -(** Floating-point comparison between x and y: -- ZF = 1 if x=y or unordered, 0 if x<>y -- CF = 1 if x<y or unordered, 0 if x>=y -- PF = 1 if unordered, 0 if ordered. -- SF and 0F are undefined -*) - -Definition compare_floats (vx vy: val) (rs: regset) : regset := - match vx, vy with - | Vfloat x, Vfloat y => - rs #ZF <- (Val.of_bool (negb (Float.cmp Cne x y))) - #CF <- (Val.of_bool (negb (Float.cmp Cge x y))) - #PF <- (Val.of_bool (negb (Float.cmp Ceq x y || Float.cmp Clt x y || Float.cmp Cgt x y))) - #SF <- Vundef - #OF <- Vundef - | _, _ => - undef_regs (CR ZF :: CR CF :: CR PF :: CR SF :: CR OF :: nil) rs - end. - -Definition compare_floats32 (vx vy: val) (rs: regset) : regset := - match vx, vy with - | Vsingle x, Vsingle y => - rs #ZF <- (Val.of_bool (negb (Float32.cmp Cne x y))) - #CF <- (Val.of_bool (negb (Float32.cmp Cge x y))) - #PF <- (Val.of_bool (negb (Float32.cmp Ceq x y || Float32.cmp Clt x y || Float32.cmp Cgt x y))) - #SF <- Vundef - #OF <- Vundef - | _, _ => - undef_regs (CR ZF :: CR CF :: CR PF :: CR SF :: CR OF :: nil) rs - end. - -(** Testing a condition *) - -Definition eval_testcond (c: testcond) (rs: regset) : option bool := - match c with - | Cond_e => - match rs ZF with - | Vint n => Some (Int.eq n Int.one) - | _ => None - end - | Cond_ne => - match rs ZF with - | Vint n => Some (Int.eq n Int.zero) - | _ => None - end - | Cond_b => - match rs CF with - | Vint n => Some (Int.eq n Int.one) - | _ => None - end - | Cond_be => - match rs CF, rs ZF with - | Vint c, Vint z => Some (Int.eq c Int.one || Int.eq z Int.one) - | _, _ => None - end - | Cond_ae => - match rs CF with - | Vint n => Some (Int.eq n Int.zero) - | _ => None - end - | Cond_a => - match rs CF, rs ZF with - | Vint c, Vint z => Some (Int.eq c Int.zero && Int.eq z Int.zero) - | _, _ => None - end - | Cond_l => - match rs OF, rs SF with - | Vint o, Vint s => Some (Int.eq (Int.xor o s) Int.one) - | _, _ => None - end - | Cond_le => - match rs OF, rs SF, rs ZF with - | Vint o, Vint s, Vint z => Some (Int.eq (Int.xor o s) Int.one || Int.eq z Int.one) - | _, _, _ => None - end - | Cond_ge => - match rs OF, rs SF with - | Vint o, Vint s => Some (Int.eq (Int.xor o s) Int.zero) - | _, _ => None - end - | Cond_g => - match rs OF, rs SF, rs ZF with - | Vint o, Vint s, Vint z => Some (Int.eq (Int.xor o s) Int.zero && Int.eq z Int.zero) - | _, _, _ => None - end - | Cond_p => - match rs PF with - | Vint n => Some (Int.eq n Int.one) - | _ => None - end - | Cond_np => - match rs PF with - | Vint n => Some (Int.eq n Int.zero) - | _ => None - end - end. - -(** The semantics is purely small-step and defined as a function - from the current state (a register set + a memory state) - to either [Next rs' m'] where [rs'] and [m'] are the updated register - set and memory state after execution of the instruction at [rs#PC], - or [Stuck] if the processor is stuck. *) - -Inductive outcome: Type := - | Next: regset -> mem -> outcome - | Stuck: outcome. - -(** Manipulations over the [PC] register: continuing with the next - instruction ([nextinstr]) or branching to a label ([goto_label]). - [nextinstr_nf] is a variant of [nextinstr] that sets condition flags - to [Vundef] in addition to incrementing the [PC]. *) - -Definition nextinstr (rs: regset) := - rs#PC <- (Val.offset_ptr rs#PC Ptrofs.one). - -Definition nextinstr_nf (rs: regset) : regset := - nextinstr (undef_regs (CR ZF :: CR CF :: CR PF :: CR SF :: CR OF :: nil) rs). - -Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) := - match label_pos lbl 0 (fn_code f) with - | None => Stuck - | Some pos => - match rs#PC with - | Vptr b ofs => Next (rs#PC <- (Vptr b (Ptrofs.repr pos))) m - | _ => Stuck - end - end. - -(** Auxiliaries for memory accesses. *) - -Definition exec_load (chunk: memory_chunk) (m: mem) - (a: addrmode) (rs: regset) (rd: preg) := - match Mem.loadv chunk m (eval_addrmode a rs) with - | Some v => Next (nextinstr_nf (rs#rd <- v)) m - | None => Stuck - end. - -Definition exec_store (chunk: memory_chunk) (m: mem) - (a: addrmode) (rs: regset) (r1: preg) - (destroyed: list preg) := - match Mem.storev chunk m (eval_addrmode a rs) (rs r1) with - | Some m' => Next (nextinstr_nf (undef_regs destroyed rs)) m' - | None => Stuck - end. - -(** Execution of a single instruction [i] in initial state - [rs] and [m]. Return updated state. For instructions - that correspond to actual IA32 instructions, the cases are - straightforward transliterations of the informal descriptions - given in the IA32 reference manuals. For pseudo-instructions, - refer to the informal descriptions given above. - - Note that we set to [Vundef] the registers used as temporaries by - the expansions of the pseudo-instructions, so that the IA32 code - we generate cannot use those registers to hold values that must - survive the execution of the pseudo-instruction. - - Concerning condition flags, the comparison instructions set them - accurately; other instructions (moves, [lea]) preserve them; - and all other instruction set those flags to [Vundef], to reflect - the fact that the processor updates some or all of those flags, - but we do not need to model this precisely. -*) - -Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : outcome := - match i with - (** Moves *) - | Pmov_rr rd r1 => - Next (nextinstr (rs#rd <- (rs r1))) m - | Pmovl_ri rd n => - Next (nextinstr_nf (rs#rd <- (Vint n))) m - | Pmovq_ri rd n => - Next (nextinstr_nf (rs#rd <- (Vlong n))) m - | Pmov_rs rd id => - Next (nextinstr_nf (rs#rd <- (Genv.symbol_address ge id Ptrofs.zero))) m - | Pmovl_rm rd a => - exec_load Mint32 m a rs rd - | Pmovq_rm rd a => - exec_load Mint64 m a rs rd - | Pmovl_mr a r1 => - exec_store Mint32 m a rs r1 nil - | Pmovq_mr a r1 => - exec_store Mint64 m a rs r1 nil - | Pmovsd_ff rd r1 => - Next (nextinstr (rs#rd <- (rs r1))) m - | Pmovsd_fi rd n => - Next (nextinstr (rs#rd <- (Vfloat n))) m - | Pmovsd_fm rd a => - exec_load Mfloat64 m a rs rd - | Pmovsd_mf a r1 => - exec_store Mfloat64 m a rs r1 nil - | Pmovss_fi rd n => - Next (nextinstr (rs#rd <- (Vsingle n))) m - | Pmovss_fm rd a => - exec_load Mfloat32 m a rs rd - | Pmovss_mf a r1 => - exec_store Mfloat32 m a rs r1 nil - | Pfldl_m a => - exec_load Mfloat64 m a rs ST0 - | Pfstpl_m a => - exec_store Mfloat64 m a rs ST0 (ST0 :: nil) - | Pflds_m a => - exec_load Mfloat32 m a rs ST0 - | Pfstps_m a => - exec_store Mfloat32 m a rs ST0 (ST0 :: nil) - (** Moves with conversion *) - | Pmovb_mr a r1 => - exec_store Mint8unsigned m a rs r1 nil - | Pmovw_mr a r1 => - exec_store Mint16unsigned m a rs r1 nil - | Pmovzb_rr rd r1 => - Next (nextinstr (rs#rd <- (Val.zero_ext 8 rs#r1))) m - | Pmovzb_rm rd a => - exec_load Mint8unsigned m a rs rd - | Pmovsb_rr rd r1 => - Next (nextinstr (rs#rd <- (Val.sign_ext 8 rs#r1))) m - | Pmovsb_rm rd a => - exec_load Mint8signed m a rs rd - | Pmovzw_rr rd r1 => - Next (nextinstr (rs#rd <- (Val.zero_ext 16 rs#r1))) m - | Pmovzw_rm rd a => - exec_load Mint16unsigned m a rs rd - | Pmovsw_rr rd r1 => - Next (nextinstr (rs#rd <- (Val.sign_ext 16 rs#r1))) m - | Pmovsw_rm rd a => - exec_load Mint16signed m a rs rd - | Pmovzl_rr rd r1 => - Next (nextinstr (rs#rd <- (Val.longofintu rs#r1))) m - | Pmovsl_rr rd r1 => - Next (nextinstr (rs#rd <- (Val.longofint rs#r1))) m - | Pmovls_rr rd => - Next (nextinstr (rs#rd <- (Val.loword rs#rd))) m - | Pcvtsd2ss_ff rd r1 => - Next (nextinstr (rs#rd <- (Val.singleoffloat rs#r1))) m - | Pcvtss2sd_ff rd r1 => - Next (nextinstr (rs#rd <- (Val.floatofsingle rs#r1))) m - | Pcvttsd2si_rf rd r1 => - Next (nextinstr (rs#rd <- (Val.maketotal (Val.intoffloat rs#r1)))) m - | Pcvtsi2sd_fr rd r1 => - Next (nextinstr (rs#rd <- (Val.maketotal (Val.floatofint rs#r1)))) m - | Pcvttss2si_rf rd r1 => - Next (nextinstr (rs#rd <- (Val.maketotal (Val.intofsingle rs#r1)))) m - | Pcvtsi2ss_fr rd r1 => - Next (nextinstr (rs#rd <- (Val.maketotal (Val.singleofint rs#r1)))) m - | Pcvttsd2sl_rf rd r1 => - Next (nextinstr (rs#rd <- (Val.maketotal (Val.longoffloat rs#r1)))) m - | Pcvtsl2sd_fr rd r1 => - Next (nextinstr (rs#rd <- (Val.maketotal (Val.floatoflong rs#r1)))) m - | Pcvttss2sl_rf rd r1 => - Next (nextinstr (rs#rd <- (Val.maketotal (Val.longofsingle rs#r1)))) m - | Pcvtsl2ss_fr rd r1 => - Next (nextinstr (rs#rd <- (Val.maketotal (Val.singleoflong rs#r1)))) m - (** Integer arithmetic *) - | Pleal rd a => - Next (nextinstr (rs#rd <- (eval_addrmode32 a rs))) m - | Pleaq rd a => - Next (nextinstr (rs#rd <- (eval_addrmode64 a rs))) m - | Pnegl rd => - Next (nextinstr_nf (rs#rd <- (Val.neg rs#rd))) m - | Pnegq rd => - Next (nextinstr_nf (rs#rd <- (Val.negl rs#rd))) m - | Paddl_ri rd n => - Next (nextinstr_nf (rs#rd <- (Val.add rs#rd (Vint n)))) m - | Paddq_ri rd n => - Next (nextinstr_nf (rs#rd <- (Val.addl rs#rd (Vlong n)))) m - | Psubl_rr rd r1 => - Next (nextinstr_nf (rs#rd <- (Val.sub rs#rd rs#r1))) m - | Psubq_rr rd r1 => - Next (nextinstr_nf (rs#rd <- (Val.subl rs#rd rs#r1))) m - | Pimull_rr rd r1 => - Next (nextinstr_nf (rs#rd <- (Val.mul rs#rd rs#r1))) m - | Pimulq_rr rd r1 => - Next (nextinstr_nf (rs#rd <- (Val.mull rs#rd rs#r1))) m - | Pimull_ri rd n => - Next (nextinstr_nf (rs#rd <- (Val.mul rs#rd (Vint n)))) m - | Pimulq_ri rd n => - Next (nextinstr_nf (rs#rd <- (Val.mull rs#rd (Vlong n)))) m - | Pimull_r r1 => - Next (nextinstr_nf (rs#RAX <- (Val.mul rs#RAX rs#r1) - #RDX <- (Val.mulhs rs#RAX rs#r1))) m - | Pimulq_r r1 => - Next (nextinstr_nf (rs#RAX <- (Val.mull rs#RAX rs#r1) - #RDX <- (Val.mullhs rs#RAX rs#r1))) m - | Pmull_r r1 => - Next (nextinstr_nf (rs#RAX <- (Val.mul rs#RAX rs#r1) - #RDX <- (Val.mulhu rs#RAX rs#r1))) m - | Pmulq_r r1 => - Next (nextinstr_nf (rs#RAX <- (Val.mull rs#RAX rs#r1) - #RDX <- (Val.mullhu rs#RAX rs#r1))) m - | Pcltd => - Next (nextinstr_nf (rs#RDX <- (Val.shr rs#RAX (Vint (Int.repr 31))))) m - | Pcqto => - Next (nextinstr_nf (rs#RDX <- (Val.shrl rs#RAX (Vint (Int.repr 63))))) m - | Pdivl r1 => - match rs#RDX, rs#RAX, rs#r1 with - | Vint nh, Vint nl, Vint d => - match Int.divmodu2 nh nl d with - | Some(q, r) => Next (nextinstr_nf (rs#RAX <- (Vint q) #RDX <- (Vint r))) m - | None => Stuck - end - | _, _, _ => Stuck - end - | Pdivq r1 => - match rs#RDX, rs#RAX, rs#r1 with - | Vlong nh, Vlong nl, Vlong d => - match Int64.divmodu2 nh nl d with - | Some(q, r) => Next (nextinstr_nf (rs#RAX <- (Vlong q) #RDX <- (Vlong r))) m - | None => Stuck - end - | _, _, _ => Stuck - end - | Pidivl r1 => - match rs#RDX, rs#RAX, rs#r1 with - | Vint nh, Vint nl, Vint d => - match Int.divmods2 nh nl d with - | Some(q, r) => Next (nextinstr_nf (rs#RAX <- (Vint q) #RDX <- (Vint r))) m - | None => Stuck - end - | _, _, _ => Stuck - end - | Pidivq r1 => - match rs#RDX, rs#RAX, rs#r1 with - | Vlong nh, Vlong nl, Vlong d => - match Int64.divmods2 nh nl d with - | Some(q, r) => Next (nextinstr_nf (rs#RAX <- (Vlong q) #RDX <- (Vlong r))) m - | None => Stuck - end - | _, _, _ => Stuck - end - | Pandl_rr rd r1 => - Next (nextinstr_nf (rs#rd <- (Val.and rs#rd rs#r1))) m - | Pandq_rr rd r1 => - Next (nextinstr_nf (rs#rd <- (Val.andl rs#rd rs#r1))) m - | Pandl_ri rd n => - Next (nextinstr_nf (rs#rd <- (Val.and rs#rd (Vint n)))) m - | Pandq_ri rd n => - Next (nextinstr_nf (rs#rd <- (Val.andl rs#rd (Vlong n)))) m - | Porl_rr rd r1 => - Next (nextinstr_nf (rs#rd <- (Val.or rs#rd rs#r1))) m - | Porq_rr rd r1 => - Next (nextinstr_nf (rs#rd <- (Val.orl rs#rd rs#r1))) m - | Porl_ri rd n => - Next (nextinstr_nf (rs#rd <- (Val.or rs#rd (Vint n)))) m - | Porq_ri rd n => - Next (nextinstr_nf (rs#rd <- (Val.orl rs#rd (Vlong n)))) m - | Pxorl_r rd => - Next (nextinstr_nf (rs#rd <- Vzero)) m - | Pxorq_r rd => - Next (nextinstr_nf (rs#rd <- (Vlong Int64.zero))) m - | Pxorl_rr rd r1 => - Next (nextinstr_nf (rs#rd <- (Val.xor rs#rd rs#r1))) m - | Pxorq_rr rd r1 => - Next (nextinstr_nf (rs#rd <- (Val.xorl rs#rd rs#r1))) m - | Pxorl_ri rd n => - Next (nextinstr_nf (rs#rd <- (Val.xor rs#rd (Vint n)))) m - | Pxorq_ri rd n => - Next (nextinstr_nf (rs#rd <- (Val.xorl rs#rd (Vlong n)))) m - | Pnotl rd => - Next (nextinstr_nf (rs#rd <- (Val.notint rs#rd))) m - | Pnotq rd => - Next (nextinstr_nf (rs#rd <- (Val.notl rs#rd))) m - | Psall_rcl rd => - Next (nextinstr_nf (rs#rd <- (Val.shl rs#rd rs#RCX))) m - | Psalq_rcl rd => - Next (nextinstr_nf (rs#rd <- (Val.shll rs#rd rs#RCX))) m - | Psall_ri rd n => - Next (nextinstr_nf (rs#rd <- (Val.shl rs#rd (Vint n)))) m - | Psalq_ri rd n => - Next (nextinstr_nf (rs#rd <- (Val.shll rs#rd (Vint n)))) m - | Pshrl_rcl rd => - Next (nextinstr_nf (rs#rd <- (Val.shru rs#rd rs#RCX))) m - | Pshrq_rcl rd => - Next (nextinstr_nf (rs#rd <- (Val.shrlu rs#rd rs#RCX))) m - | Pshrl_ri rd n => - Next (nextinstr_nf (rs#rd <- (Val.shru rs#rd (Vint n)))) m - | Pshrq_ri rd n => - Next (nextinstr_nf (rs#rd <- (Val.shrlu rs#rd (Vint n)))) m - | Psarl_rcl rd => - Next (nextinstr_nf (rs#rd <- (Val.shr rs#rd rs#RCX))) m - | Psarq_rcl rd => - Next (nextinstr_nf (rs#rd <- (Val.shrl rs#rd rs#RCX))) m - | Psarl_ri rd n => - Next (nextinstr_nf (rs#rd <- (Val.shr rs#rd (Vint n)))) m - | Psarq_ri rd n => - Next (nextinstr_nf (rs#rd <- (Val.shrl rs#rd (Vint n)))) m - | Pshld_ri rd r1 n => - Next (nextinstr_nf - (rs#rd <- (Val.or (Val.shl rs#rd (Vint n)) - (Val.shru rs#r1 (Vint (Int.sub Int.iwordsize n)))))) m - | Prorl_ri rd n => - Next (nextinstr_nf (rs#rd <- (Val.ror rs#rd (Vint n)))) m - | Prorq_ri rd n => - Next (nextinstr_nf (rs#rd <- (Val.rorl rs#rd (Vint n)))) m - | Pcmpl_rr r1 r2 => - Next (nextinstr (compare_ints (rs r1) (rs r2) rs m)) m - | Pcmpq_rr r1 r2 => - Next (nextinstr (compare_longs (rs r1) (rs r2) rs m)) m - | Pcmpl_ri r1 n => - Next (nextinstr (compare_ints (rs r1) (Vint n) rs m)) m - | Pcmpq_ri r1 n => - Next (nextinstr (compare_longs (rs r1) (Vlong n) rs m)) m - | Ptestl_rr r1 r2 => - Next (nextinstr (compare_ints (Val.and (rs r1) (rs r2)) Vzero rs m)) m - | Ptestq_rr r1 r2 => - Next (nextinstr (compare_longs (Val.andl (rs r1) (rs r2)) (Vlong Int64.zero) rs m)) m - | Ptestl_ri r1 n => - Next (nextinstr (compare_ints (Val.and (rs r1) (Vint n)) Vzero rs m)) m - | Ptestq_ri r1 n => - Next (nextinstr (compare_longs (Val.andl (rs r1) (Vlong n)) (Vlong Int64.zero) rs m)) m - | Pcmov c rd r1 => - match eval_testcond c rs with - | Some true => Next (nextinstr (rs#rd <- (rs#r1))) m - | Some false => Next (nextinstr rs) m - | None => Next (nextinstr (rs#rd <- Vundef)) m - end - | Psetcc c rd => - Next (nextinstr (rs#rd <- (Val.of_optbool (eval_testcond c rs)))) m - (** Arithmetic operations over double-precision floats *) - | Paddd_ff rd r1 => - Next (nextinstr (rs#rd <- (Val.addf rs#rd rs#r1))) m - | Psubd_ff rd r1 => - Next (nextinstr (rs#rd <- (Val.subf rs#rd rs#r1))) m - | Pmuld_ff rd r1 => - Next (nextinstr (rs#rd <- (Val.mulf rs#rd rs#r1))) m - | Pdivd_ff rd r1 => - Next (nextinstr (rs#rd <- (Val.divf rs#rd rs#r1))) m - | Pnegd rd => - Next (nextinstr (rs#rd <- (Val.negf rs#rd))) m - | Pabsd rd => - Next (nextinstr (rs#rd <- (Val.absf rs#rd))) m - | Pcomisd_ff r1 r2 => - Next (nextinstr (compare_floats (rs r1) (rs r2) rs)) m - | Pxorpd_f rd => - Next (nextinstr_nf (rs#rd <- (Vfloat Float.zero))) m - (** Arithmetic operations over single-precision floats *) - | Padds_ff rd r1 => - Next (nextinstr (rs#rd <- (Val.addfs rs#rd rs#r1))) m - | Psubs_ff rd r1 => - Next (nextinstr (rs#rd <- (Val.subfs rs#rd rs#r1))) m - | Pmuls_ff rd r1 => - Next (nextinstr (rs#rd <- (Val.mulfs rs#rd rs#r1))) m - | Pdivs_ff rd r1 => - Next (nextinstr (rs#rd <- (Val.divfs rs#rd rs#r1))) m - | Pnegs rd => - Next (nextinstr (rs#rd <- (Val.negfs rs#rd))) m - | Pabss rd => - Next (nextinstr (rs#rd <- (Val.absfs rs#rd))) m - | Pcomiss_ff r1 r2 => - Next (nextinstr (compare_floats32 (rs r1) (rs r2) rs)) m - | Pxorps_f rd => - Next (nextinstr_nf (rs#rd <- (Vsingle Float32.zero))) m - (** Branches and calls *) - | Pjmp_l lbl => - goto_label f lbl rs m - | Pjmp_s id sg => - Next (rs#PC <- (Genv.symbol_address ge id Ptrofs.zero)) m - | Pjmp_r r sg => - Next (rs#PC <- (rs r)) m - | Pjcc cond lbl => - match eval_testcond cond rs with - | Some true => goto_label f lbl rs m - | Some false => Next (nextinstr rs) m - | None => Stuck - end - | Pjcc2 cond1 cond2 lbl => - match eval_testcond cond1 rs, eval_testcond cond2 rs with - | Some true, Some true => goto_label f lbl rs m - | Some _, Some _ => Next (nextinstr rs) m - | _, _ => Stuck - end - | Pjmptbl r tbl => - match rs#r with - | Vint n => - match list_nth_z tbl (Int.unsigned n) with - | None => Stuck - | Some lbl => goto_label f lbl (rs #RAX <- Vundef #RDX <- Vundef) m - end - | _ => Stuck - end - | Pcall_s id sg => - Next (rs#RA <- (Val.offset_ptr rs#PC Ptrofs.one) #PC <- (Genv.symbol_address ge id Ptrofs.zero)) m - | Pcall_r r sg => - Next (rs#RA <- (Val.offset_ptr rs#PC Ptrofs.one) #PC <- (rs r)) m - | Pret => - Next (rs#PC <- (rs#RA)) m - (** Saving and restoring registers *) - | Pmov_rm_a rd a => - exec_load (if Archi.ptr64 then Many64 else Many32) m a rs rd - | Pmov_mr_a a r1 => - exec_store (if Archi.ptr64 then Many64 else Many32) m a rs r1 nil - | Pmovsd_fm_a rd a => - exec_load Many64 m a rs rd - | Pmovsd_mf_a a r1 => - exec_store Many64 m a rs r1 nil - (** Pseudo-instructions *) - | Plabel lbl => - Next (nextinstr rs) m - | Pallocframe sz ofs_ra ofs_link => - let (m1, stk) := Mem.alloc m 0 sz in - let sp := Vptr stk Ptrofs.zero in - match Mem.storev Mptr m1 (Val.offset_ptr sp ofs_link) rs#RSP with - | None => Stuck - | Some m2 => - match Mem.storev Mptr m2 (Val.offset_ptr sp ofs_ra) rs#RA with - | None => Stuck - | Some m3 => Next (nextinstr (rs #RAX <- (rs#RSP) #RSP <- sp)) m3 - end - end - | Pfreeframe sz ofs_ra ofs_link => - match Mem.loadv Mptr m (Val.offset_ptr rs#RSP ofs_ra) with - | None => Stuck - | Some ra => - match Mem.loadv Mptr m (Val.offset_ptr rs#RSP ofs_link) with - | None => Stuck - | Some sp => - match rs#RSP with - | Vptr stk ofs => - match Mem.free m stk 0 sz with - | None => Stuck - | Some m' => Next (nextinstr (rs#RSP <- sp #RA <- ra)) m' - end - | _ => Stuck - end - end - end - | Pbuiltin ef args res => - Stuck (**r treated specially below *) - (** The following instructions and directives are not generated - directly by [Asmgen], so we do not model them. *) - | Padcl_ri _ _ - | Padcl_rr _ _ - | Paddl_mi _ _ - | Paddl_rr _ _ - | Pbsfl _ _ - | Pbsfq _ _ - | Pbsrl _ _ - | Pbsrq _ _ - | Pbswap64 _ - | Pbswap32 _ - | Pbswap16 _ - | Pcfi_adjust _ - | Pfmadd132 _ _ _ - | Pfmadd213 _ _ _ - | Pfmadd231 _ _ _ - | Pfmsub132 _ _ _ - | Pfmsub213 _ _ _ - | Pfmsub231 _ _ _ - | Pfnmadd132 _ _ _ - | Pfnmadd213 _ _ _ - | Pfnmadd231 _ _ _ - | Pfnmsub132 _ _ _ - | Pfnmsub213 _ _ _ - | Pfnmsub231 _ _ _ - | Pmaxsd _ _ - | Pminsd _ _ - | Pmovb_rm _ _ - | Pmovsq_rm _ _ - | Pmovsq_mr _ _ - | Pmovsb - | Pmovsw - | Pmovw_rm _ _ - | Prep_movsl - | Psbbl_rr _ _ - | Psqrtsd _ _ - | Psubl_ri _ _ - | Psubq_ri _ _ => Stuck - end. - -(** Translation of the LTL/Linear/Mach view of machine registers - to the Asm view. *) - -Definition preg_of (r: mreg) : preg := - match r with - | AX => IR RAX - | BX => IR RBX - | CX => IR RCX - | DX => IR RDX - | SI => IR RSI - | DI => IR RDI - | BP => IR RBP - | Machregs.R8 => IR R8 - | Machregs.R9 => IR R9 - | Machregs.R10 => IR R10 - | Machregs.R11 => IR R11 - | Machregs.R12 => IR R12 - | Machregs.R13 => IR R13 - | Machregs.R14 => IR R14 - | Machregs.R15 => IR R15 - | X0 => FR XMM0 - | X1 => FR XMM1 - | X2 => FR XMM2 - | X3 => FR XMM3 - | X4 => FR XMM4 - | X5 => FR XMM5 - | X6 => FR XMM6 - | X7 => FR XMM7 - | X8 => FR XMM8 - | X9 => FR XMM9 - | X10 => FR XMM10 - | X11 => FR XMM11 - | X12 => FR XMM12 - | X13 => FR XMM13 - | X14 => FR XMM14 - | X15 => FR XMM15 - | FP0 => ST0 - end. - -(** Extract the values of the arguments of an external call. - We exploit the calling conventions from module [Conventions], except that - we use machine registers instead of locations. *) - -Inductive extcall_arg (rs: regset) (m: mem): loc -> val -> Prop := - | extcall_arg_reg: forall r, - extcall_arg rs m (R r) (rs (preg_of r)) - | extcall_arg_stack: forall ofs ty bofs v, - bofs = Stacklayout.fe_ofs_arg + 4 * ofs -> - Mem.loadv (chunk_of_type ty) m - (Val.offset_ptr (rs (IR RSP)) (Ptrofs.repr bofs)) = Some v -> - extcall_arg rs m (S Outgoing ofs ty) v. - -Inductive extcall_arg_pair (rs: regset) (m: mem): rpair loc -> val -> Prop := - | extcall_arg_one: forall l v, - extcall_arg rs m l v -> - extcall_arg_pair rs m (One l) v - | extcall_arg_twolong: forall hi lo vhi vlo, - extcall_arg rs m hi vhi -> - extcall_arg rs m lo vlo -> - extcall_arg_pair rs m (Twolong hi lo) (Val.longofwords vhi vlo). - -Definition extcall_arguments - (rs: regset) (m: mem) (sg: signature) (args: list val) : Prop := - list_forall2 (extcall_arg_pair rs m) (loc_arguments sg) args. - -Definition loc_external_result (sg: signature) : rpair preg := - map_rpair preg_of (loc_result sg). - -(** Execution of the instruction at [rs#PC]. *) - -Inductive state: Type := - | State: regset -> mem -> state. - -Inductive step: state -> trace -> state -> Prop := - | exec_step_internal: - forall b ofs f i rs m rs' m', - rs PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some (Internal f) -> - find_instr (Ptrofs.unsigned ofs) f.(fn_code) = Some i -> - exec_instr f i rs m = Next rs' m' -> - step (State rs m) E0 (State rs' m') - | exec_step_builtin: - forall b ofs f ef args res rs m vargs t vres rs' m', - rs PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some (Internal f) -> - find_instr (Ptrofs.unsigned ofs) f.(fn_code) = Some (Pbuiltin ef args res) -> - eval_builtin_args ge rs (rs RSP) m args vargs -> - external_call ef ge vargs m t vres m' -> - rs' = nextinstr_nf - (set_res res vres - (undef_regs (map preg_of (destroyed_by_builtin ef)) rs)) -> - step (State rs m) t (State rs' m') - | exec_step_external: - forall b ef args res rs m t rs' m', - rs PC = Vptr b Ptrofs.zero -> - Genv.find_funct_ptr ge b = Some (External ef) -> - extcall_arguments rs m (ef_sig ef) args -> - external_call ef ge args m t res m' -> - rs' = (set_pair (loc_external_result (ef_sig ef)) res rs) #PC <- (rs RA) -> - step (State rs m) t (State rs' m'). - -End RELSEM. - -(** Execution of whole programs. *) - -Inductive initial_state (p: program): state -> Prop := - | initial_state_intro: forall m0, - Genv.init_mem p = Some m0 -> - let ge := Genv.globalenv p in - let rs0 := - (Pregmap.init Vundef) - # PC <- (Genv.symbol_address ge p.(prog_main) Ptrofs.zero) - # RA <- Vnullptr - # RSP <- Vnullptr in - initial_state p (State rs0 m0). - -Inductive final_state: state -> int -> Prop := - | final_state_intro: forall rs m r, - rs#PC = Vnullptr -> - rs#RAX = Vint r -> - final_state (State rs m) r. - -Definition semantics (p: program) := - Semantics step (initial_state p) final_state (Genv.globalenv p). - -(** Determinacy of the [Asm] semantics. *) - -Remark extcall_arguments_determ: - forall rs m sg args1 args2, - extcall_arguments rs m sg args1 -> extcall_arguments rs m sg args2 -> args1 = args2. -Proof. - intros until m. - assert (A: forall l v1 v2, - extcall_arg rs m l v1 -> extcall_arg rs m l v2 -> v1 = v2). - { intros. inv H; inv H0; congruence. } - assert (B: forall p v1 v2, - extcall_arg_pair rs m p v1 -> extcall_arg_pair rs m p v2 -> v1 = v2). - { intros. inv H; inv H0. - eapply A; eauto. - f_equal; eapply A; eauto. } - assert (C: forall ll vl1, list_forall2 (extcall_arg_pair rs m) ll vl1 -> - forall vl2, list_forall2 (extcall_arg_pair rs m) ll vl2 -> vl1 = vl2). - { - induction 1; intros vl2 EA; inv EA. - auto. - f_equal; eauto. } - intros. eapply C; eauto. -Qed. - -Lemma semantics_determinate: forall p, determinate (semantics p). -Proof. -Ltac Equalities := - match goal with - | [ H1: ?a = ?b, H2: ?a = ?c |- _ ] => - rewrite H1 in H2; inv H2; Equalities - | _ => idtac - end. - intros; constructor; simpl; intros. -- (* determ *) - inv H; inv H0; Equalities. -+ split. constructor. auto. -+ discriminate. -+ discriminate. -+ assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0. - exploit external_call_determ. eexact H5. eexact H11. intros [A B]. - split. auto. intros. destruct B; auto. subst. auto. -+ assert (args0 = args) by (eapply extcall_arguments_determ; eauto). subst args0. - exploit external_call_determ. eexact H4. eexact H9. intros [A B]. - split. auto. intros. destruct B; auto. subst. auto. -- (* trace length *) - red; intros; inv H; simpl. - omega. - eapply external_call_trace_length; eauto. - eapply external_call_trace_length; eauto. -- (* initial states *) - inv H; inv H0. f_equal. congruence. -- (* final no step *) - assert (NOTNULL: forall b ofs, Vnullptr <> Vptr b ofs). - { intros; unfold Vnullptr; destruct Archi.ptr64; congruence. } - inv H. red; intros; red; intros. inv H; rewrite H0 in *; eelim NOTNULL; eauto. -- (* final states *) - inv H; inv H0. congruence. -Qed. - -(** Classification functions for processor registers (used in Asmgenproof). *) - -Definition data_preg (r: preg) : bool := - match r with - | PC => false - | IR _ => true - | FR _ => true - | ST0 => true - | CR _ => false - | RA => false - end. - diff --git a/ia32/AsmToJSON.ml b/ia32/AsmToJSON.ml deleted file mode 100644 index 3214491f..00000000 --- a/ia32/AsmToJSON.ml +++ /dev/null @@ -1,17 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) -(* *) -(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *) -(* is distributed under the terms of the INRIA Non-Commercial *) -(* License Agreement. *) -(* *) -(* *********************************************************************) - -(* Simple functions to serialize ia32 Asm to JSON *) - -(* Dummy function *) -let p_program oc prog = - () diff --git a/ia32/AsmToJSON.mli b/ia32/AsmToJSON.mli deleted file mode 100644 index 20bcba5e..00000000 --- a/ia32/AsmToJSON.mli +++ /dev/null @@ -1,13 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) -(* *) -(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *) -(* is distributed under the terms of the INRIA Non-Commercial *) -(* License Agreement. *) -(* *) -(* *********************************************************************) - -val p_program: out_channel -> (Asm.coq_function AST.fundef, 'a) AST.program -> unit diff --git a/ia32/Asmexpand.ml b/ia32/Asmexpand.ml deleted file mode 100644 index 0436bc86..00000000 --- a/ia32/Asmexpand.ml +++ /dev/null @@ -1,638 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(* Expanding built-ins and some pseudo-instructions by rewriting - of the IA32 assembly code. *) - -open Asm -open Asmexpandaux -open AST -open Camlcoq -open Datatypes - -exception Error of string - -(* Useful constants and helper functions *) - -let _0 = Integers.Int.zero -let _1 = Integers.Int.one -let _2 = coqint_of_camlint 2l -let _4 = coqint_of_camlint 4l -let _8 = coqint_of_camlint 8l - -let _0z = Z.zero -let _1z = Z.one -let _2z = Z.of_sint 2 -let _4z = Z.of_sint 4 -let _8z = Z.of_sint 8 -let _16z = Z.of_sint 16 - -let stack_alignment () = 16 - -(* Pseudo instructions for 32/64 bit compatibility *) - -let _Plea (r, addr) = - if Archi.ptr64 then Pleaq (r, addr) else Pleal (r, addr) - -(* SP adjustment to allocate or free a stack frame *) - -let align n a = - if n >= 0 then (n + a - 1) land (-a) else n land (-a) - -let sp_adjustment_32 sz = - let sz = Z.to_int sz in - (* Preserve proper alignment of the stack *) - let sz = align sz (stack_alignment ()) in - (* The top 4 bytes have already been allocated by the "call" instruction. *) - sz - 4 - -let sp_adjustment_64 sz = - let sz = Z.to_int sz in - if is_current_function_variadic() then begin - (* If variadic, add room for register save area, which must be 16-aligned *) - let ofs = align (sz - 8) 16 in - let sz = ofs + 176 (* save area *) + 8 (* return address *) in - (* Preserve proper alignment of the stack *) - let sz = align sz 16 in - (* The top 8 bytes have already been allocated by the "call" instruction. *) - (sz - 8, ofs) - end else begin - (* Preserve proper alignment of the stack *) - let sz = align sz 16 in - (* The top 8 bytes have already been allocated by the "call" instruction. *) - (sz - 8, -1) - end - -(* Built-ins. They come in two flavors: - - annotation statements: take their arguments in registers or stack - locations; generate no code; - - inlined by the compiler: take their arguments in arbitrary - registers; preserve all registers except ECX, EDX, XMM6 and XMM7. *) - -(* Handling of annotations *) - -let expand_annot_val txt targ args res = - emit (Pbuiltin (EF_annot(txt,[targ]), args, BR_none)); - match args, res with - | [BA(IR src)], BR(IR dst) -> - if dst <> src then emit (Pmov_rr (dst,src)) - | [BA(FR src)], BR(FR dst) -> - if dst <> src then emit (Pmovsd_ff (dst,src)) - | _, _ -> - raise (Error "ill-formed __builtin_annot_intval") - -(* Operations on addressing modes *) - -let offset_addressing (Addrmode(base, ofs, cst)) delta = - Addrmode(base, ofs, - match cst with - | Coq_inl n -> Coq_inl(Z.add n delta) - | Coq_inr(id, n) -> Coq_inr(id, Integers.Ptrofs.add n delta)) - -let linear_addr reg ofs = Addrmode(Some reg, None, Coq_inl ofs) -let global_addr id ofs = Addrmode(None, None, Coq_inr(id, ofs)) - -(* Translate a builtin argument into an addressing mode *) - -let addressing_of_builtin_arg = function - | BA (IR r) -> linear_addr r Z.zero - | BA_addrstack ofs -> linear_addr RSP (Integers.Ptrofs.unsigned ofs) - | BA_addrglobal(id, ofs) -> global_addr id ofs - | _ -> assert false - -(* Handling of memcpy *) - -(* Unaligned memory accesses are quite fast on IA32, so use large - memory accesses regardless of alignment. *) - -let expand_builtin_memcpy_small sz al src dst = - let rec copy src dst sz = - if sz >= 8 && Archi.ptr64 then begin - emit (Pmovq_rm (RCX, src)); - emit (Pmovq_mr (dst, RCX)); - copy (offset_addressing src _8z) (offset_addressing dst _8z) (sz - 8) - end else if sz >= 8 && !Clflags.option_ffpu then begin - emit (Pmovsq_rm (XMM7, src)); - emit (Pmovsq_mr (dst, XMM7)); - copy (offset_addressing src _8z) (offset_addressing dst _8z) (sz - 8) - end else if sz >= 4 then begin - emit (Pmovl_rm (RCX, src)); - emit (Pmovl_mr (dst, RCX)); - copy (offset_addressing src _4z) (offset_addressing dst _4z) (sz - 4) - end else if sz >= 2 then begin - emit (Pmovw_rm (RCX, src)); - emit (Pmovw_mr (dst, RCX)); - copy (offset_addressing src _2z) (offset_addressing dst _2z) (sz - 2) - end else if sz >= 1 then begin - emit (Pmovb_rm (RCX, src)); - emit (Pmovb_mr (dst, RCX)); - copy (offset_addressing src _1z) (offset_addressing dst _1z) (sz - 1) - end in - copy (addressing_of_builtin_arg src) (addressing_of_builtin_arg dst) sz - -let expand_builtin_memcpy_big sz al src dst = - if src <> BA (IR RSI) then emit (_Plea (RSI, addressing_of_builtin_arg src)); - if dst <> BA (IR RDI) then emit (_Plea (RDI, addressing_of_builtin_arg dst)); - (* TODO: movsq? *) - emit (Pmovl_ri (RCX,coqint_of_camlint (Int32.of_int (sz / 4)))); - emit Prep_movsl; - if sz mod 4 >= 2 then emit Pmovsw; - if sz mod 2 >= 1 then emit Pmovsb - -let expand_builtin_memcpy sz al args = - let (dst, src) = match args with [d; s] -> (d, s) | _ -> assert false in - if sz <= 32 - then expand_builtin_memcpy_small sz al src dst - else expand_builtin_memcpy_big sz al src dst - -(* Handling of volatile reads and writes *) - -let expand_builtin_vload_common chunk addr res = - match chunk, res with - | Mint8unsigned, BR(IR res) -> - emit (Pmovzb_rm (res,addr)) - | Mint8signed, BR(IR res) -> - emit (Pmovsb_rm (res,addr)) - | Mint16unsigned, BR(IR res) -> - emit (Pmovzw_rm (res,addr)) - | Mint16signed, BR(IR res) -> - emit (Pmovsw_rm (res,addr)) - | Mint32, BR(IR res) -> - emit (Pmovl_rm (res,addr)) - | Mint64, BR(IR res) -> - emit (Pmovq_rm (res,addr)) - | Mint64, BR_splitlong(BR(IR res1), BR(IR res2)) -> - let addr' = offset_addressing addr _4z in - if not (Asmgen.addressing_mentions addr res2) then begin - emit (Pmovl_rm (res2,addr)); - emit (Pmovl_rm (res1,addr')) - end else begin - emit (Pmovl_rm (res1,addr')); - emit (Pmovl_rm (res2,addr)) - end - | Mfloat32, BR(FR res) -> - emit (Pmovss_fm (res,addr)) - | Mfloat64, BR(FR res) -> - emit (Pmovsd_fm (res,addr)) - | _ -> - assert false - -let expand_builtin_vload chunk args res = - match args with - | [addr] -> - expand_builtin_vload_common chunk (addressing_of_builtin_arg addr) res - | _ -> - assert false - -let expand_builtin_vstore_common chunk addr src tmp = - match chunk, src with - | (Mint8signed | Mint8unsigned), BA(IR src) -> - if Archi.ptr64 || Asmgen.low_ireg src then - emit (Pmovb_mr (addr,src)) - else begin - emit (Pmov_rr (tmp,src)); - emit (Pmovb_mr (addr,tmp)) - end - | (Mint16signed | Mint16unsigned), BA(IR src) -> - emit (Pmovw_mr (addr,src)) - | Mint32, BA(IR src) -> - emit (Pmovl_mr (addr,src)) - | Mint64, BA(IR src) -> - emit (Pmovq_mr (addr,src)) - | Mint64, BA_splitlong(BA(IR src1), BA(IR src2)) -> - let addr' = offset_addressing addr _4z in - emit (Pmovl_mr (addr,src2)); - emit (Pmovl_mr (addr',src1)) - | Mfloat32, BA(FR src) -> - emit (Pmovss_mf (addr,src)) - | Mfloat64, BA(FR src) -> - emit (Pmovsd_mf (addr,src)) - | _ -> - assert false - -let expand_builtin_vstore chunk args = - match args with - | [addr; src] -> - let addr = addressing_of_builtin_arg addr in - expand_builtin_vstore_common chunk addr src - (if Asmgen.addressing_mentions addr RAX then RCX else RAX) - | _ -> assert false - -(* Handling of varargs *) - -let rec next_arg_locations ir fr ofs = function - | [] -> - (ir, fr, ofs) - | (Tint | Tlong | Tany32 | Tany64) :: l -> - if ir < 6 - then next_arg_locations (ir + 1) fr ofs l - else next_arg_locations ir fr (ofs + 8) l - | (Tfloat | Tsingle) :: l -> - if fr < 8 - then next_arg_locations ir (fr + 1) ofs l - else next_arg_locations ir fr (ofs + 8) l - -let current_function_stacksize = ref 0L - -let expand_builtin_va_start_32 r = - if not (is_current_function_variadic ()) then - invalid_arg "Fatal error: va_start used in non-vararg function"; - let ofs = - Int32.(add (add !PrintAsmaux.current_function_stacksize 4l) - (mul 4l (Z.to_int32 (Conventions1.size_arguments - (get_current_function_sig ()))))) in - emit (Pleal (RAX, linear_addr RSP (Z.of_uint32 ofs))); - emit (Pmovl_mr (linear_addr r _0z, RAX)) - -let expand_builtin_va_start_64 r = - if not (is_current_function_variadic ()) then - invalid_arg "Fatal error: va_start used in non-vararg function"; - let (ir, fr, ofs) = - next_arg_locations 0 0 0 (get_current_function_args ()) in - (* [r] points to the following struct: - struct { - unsigned int gp_offset; - unsigned int fp_offset; - void *overflow_arg_area; - void *reg_save_area; - } - gp_offset is initialized to ir * 8 - fp_offset is initialized to 6 * 8 + fr * 16 - overflow_arg_area is initialized to sp + current stacksize + ofs - reg_save_area is initialized to - sp + current stacksize - 16 - save area size (6 * 8 + 8 * 16) *) - let gp_offset = Int32.of_int (ir * 8) - and fp_offset = Int32.of_int (6 * 8 + fr * 16) - and overflow_arg_area = Int64.(add !current_function_stacksize (of_int ofs)) - and reg_save_area = Int64.(sub !current_function_stacksize 192L) in - assert (r <> RAX); - emit (Pmovl_ri (RAX, coqint_of_camlint gp_offset)); - emit (Pmovl_mr (linear_addr r _0z, RAX)); - emit (Pmovl_ri (RAX, coqint_of_camlint fp_offset)); - emit (Pmovl_mr (linear_addr r _4z, RAX)); - emit (Pleaq (RAX, linear_addr RSP (Z.of_uint64 overflow_arg_area))); - emit (Pmovq_mr (linear_addr r _8z, RAX)); - emit (Pleaq (RAX, linear_addr RSP (Z.of_uint64 reg_save_area))); - emit (Pmovq_mr (linear_addr r _16z, RAX)) - -(* FMA operations *) - -(* vfmadd<i><j><k> r1, r2, r3 performs r1 := ri * rj + rk - hence - vfmadd132 r1, r2, r3 performs r1 := r1 * r3 + r2 - vfmadd213 r1, r2, r3 performs r1 := r2 * r1 + r3 - vfmadd231 r1, r2, r3 performs r1 := r2 * r3 + r1 -*) - -let expand_fma args res i132 i213 i231 = - match args, res with - | [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) -> - if res = a1 then emit (i132 a1 a3 a2) (* a1 * a2 + a3 *) - else if res = a2 then emit (i213 a2 a1 a3) (* a1 * a2 + a3 *) - else if res = a3 then emit (i231 a3 a1 a2) (* a1 * a2 + a3 *) - else begin - emit (Pmovsd_ff(res, a3)); - emit (i231 res a1 a2) (* a1 * a2 + res *) - end - | _ -> - invalid_arg ("ill-formed fma builtin") - -(* Handling of compiler-inlined builtins *) - -let expand_builtin_inline name args res = - match name, args, res with - (* Integer arithmetic *) - | ("__builtin_bswap"| "__builtin_bswap32"), [BA(IR a1)], BR(IR res) -> - if a1 <> res then - emit (Pmov_rr (res,a1)); - emit (Pbswap32 res) - | "__builtin_bswap64", [BA(IR a1)], BR(IR res) -> - if a1 <> res then - emit (Pmov_rr (res,a1)); - emit (Pbswap64 res) - | "__builtin_bswap64", [BA_splitlong(BA(IR ah), BA(IR al))], - BR_splitlong(BR(IR rh), BR(IR rl)) -> - assert (ah = RAX && al = RDX && rh = RDX && rl = RAX); - emit (Pbswap32 RAX); - emit (Pbswap32 RDX) - | "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> - if a1 <> res then - emit (Pmov_rr (res,a1)); - emit (Pbswap16 res) - | ("__builtin_clz"|"__builtin_clzl"), [BA(IR a1)], BR(IR res) -> - emit (Pbsrl (res,a1)); - emit (Pxorl_ri(res,coqint_of_camlint 31l)) - | "__builtin_clzll", [BA(IR a1)], BR(IR res) -> - emit (Pbsrq (res,a1)); - emit (Pxorl_ri(res,coqint_of_camlint 63l)) - | "__builtin_clzll", [BA_splitlong(BA (IR ah), BA (IR al))], BR(IR res) -> - let lbl1 = new_label() in - let lbl2 = new_label() in - emit (Ptestl_rr(ah, ah)); - emit (Pjcc(Cond_e, lbl1)); - emit (Pbsrl(res, ah)); - emit (Pxorl_ri(res, coqint_of_camlint 31l)); - emit (Pjmp_l lbl2); - emit (Plabel lbl1); - emit (Pbsrl(res, al)); - emit (Pxorl_ri(res, coqint_of_camlint 63l)); - emit (Plabel lbl2) - | ("__builtin_ctz" | "__builtin_ctzl"), [BA(IR a1)], BR(IR res) -> - emit (Pbsfl (res,a1)) - | "__builtin_ctzll", [BA(IR a1)], BR(IR res) -> - emit (Pbsfq (res,a1)) - | "__builtin_ctzll", [BA_splitlong(BA (IR ah), BA (IR al))], BR(IR res) -> - let lbl1 = new_label() in - let lbl2 = new_label() in - emit (Ptestl_rr(al, al)); - emit (Pjcc(Cond_e, lbl1)); - emit (Pbsfl(res, al)); - emit (Pjmp_l lbl2); - emit (Plabel lbl1); - emit (Pbsfl(res, ah)); - emit (Paddl_ri(res, coqint_of_camlint 32l)); - emit (Plabel lbl2) - (* Float arithmetic *) - | "__builtin_fabs", [BA(FR a1)], BR(FR res) -> - if a1 <> res then - emit (Pmovsd_ff (res,a1)); - emit (Pabsd res) (* This ensures that need_masks is set to true *) - | "__builtin_fsqrt", [BA(FR a1)], BR(FR res) -> - emit (Psqrtsd (res,a1)) - | "__builtin_fmax", [BA(FR a1); BA(FR a2)], BR(FR res) -> - if res = a1 then - emit (Pmaxsd (res,a2)) - else if res = a2 then - emit (Pmaxsd (res,a1)) - else begin - emit (Pmovsd_ff (res,a1)); - emit (Pmaxsd (res,a2)) - end - | "__builtin_fmin", [BA(FR a1); BA(FR a2)], BR(FR res) -> - if res = a1 then - emit (Pminsd (res,a2)) - else if res = a2 then - emit (Pminsd (res,a1)) - else begin - emit (Pmovsd_ff (res,a1)); - emit (Pminsd (res,a2)) - end - | "__builtin_fmadd", _, _ -> - expand_fma args res - (fun r1 r2 r3 -> Pfmadd132(r1, r2, r3)) - (fun r1 r2 r3 -> Pfmadd213(r1, r2, r3)) - (fun r1 r2 r3 -> Pfmadd231(r1, r2, r3)) - | "__builtin_fmsub", _, _ -> - expand_fma args res - (fun r1 r2 r3 -> Pfmsub132(r1, r2, r3)) - (fun r1 r2 r3 -> Pfmsub213(r1, r2, r3)) - (fun r1 r2 r3 -> Pfmsub231(r1, r2, r3)) - | "__builtin_fnmadd", _, _ -> - expand_fma args res - (fun r1 r2 r3 -> Pfnmadd132(r1, r2, r3)) - (fun r1 r2 r3 -> Pfnmadd213(r1, r2, r3)) - (fun r1 r2 r3 -> Pfnmadd231(r1, r2, r3)) - | "__builtin_fnmsub", _, _ -> - expand_fma args res - (fun r1 r2 r3 -> Pfnmsub132(r1, r2, r3)) - (fun r1 r2 r3 -> Pfnmsub213(r1, r2, r3)) - (fun r1 r2 r3 -> Pfnmsub231(r1, r2, r3)) - (* 64-bit integer arithmetic *) - | "__builtin_negl", [BA_splitlong(BA(IR ah), BA(IR al))], - BR_splitlong(BR(IR rh), BR(IR rl)) -> - assert (ah = RDX && al = RAX && rh = RDX && rl = RAX); - emit (Pnegl RAX); - emit (Padcl_ri (RDX,_0)); - emit (Pnegl RDX) - | "__builtin_addl", [BA_splitlong(BA(IR ah), BA(IR al)); - BA_splitlong(BA(IR bh), BA(IR bl))], - BR_splitlong(BR(IR rh), BR(IR rl)) -> - assert (ah = RDX && al = RAX && bh = RCX && bl = RBX && rh = RDX && rl = RAX); - emit (Paddl_rr (RAX,RBX)); - emit (Padcl_rr (RDX,RCX)) - | "__builtin_subl", [BA_splitlong(BA(IR ah), BA(IR al)); - BA_splitlong(BA(IR bh), BA(IR bl))], - BR_splitlong(BR(IR rh), BR(IR rl)) -> - assert (ah = RDX && al = RAX && bh = RCX && bl = RBX && rh = RDX && rl = RAX); - emit (Psubl_rr (RAX,RBX)); - emit (Psbbl_rr (RDX,RCX)) - | "__builtin_mull", [BA(IR a); BA(IR b)], - BR_splitlong(BR(IR rh), BR(IR rl)) -> - assert (a = RAX && b = RDX && rh = RDX && rl = RAX); - emit (Pmull_r RDX) - (* Memory accesses *) - | "__builtin_read16_reversed", [BA(IR a1)], BR(IR res) -> - emit (Pmovzw_rm (res, linear_addr a1 _0)); - emit (Pbswap16 res) - | "__builtin_read32_reversed", [BA(IR a1)], BR(IR res) -> - emit (Pmovl_rm (res, linear_addr a1 _0)); - emit (Pbswap32 res) - | "__builtin_write16_reversed", [BA(IR a1); BA(IR a2)], _ -> - let tmp = if a1 = RCX then RDX else RCX in - if a2 <> tmp then - emit (Pmov_rr (tmp,a2)); - emit (Pbswap16 tmp); - emit (Pmovw_mr (linear_addr a1 _0z, tmp)) - | "__builtin_write32_reversed", [BA(IR a1); BA(IR a2)], _ -> - let tmp = if a1 = RCX then RDX else RCX in - if a2 <> tmp then - emit (Pmov_rr (tmp,a2)); - emit (Pbswap32 tmp); - emit (Pmovl_mr (linear_addr a1 _0z, tmp)) - (* Vararg stuff *) - | "__builtin_va_start", [BA(IR a)], _ -> - assert (a = RDX); - if Archi.ptr64 - then expand_builtin_va_start_64 a - else expand_builtin_va_start_32 a - (* Synchronization *) - | "__builtin_membar", [], _ -> - () - (* no operation *) - | "__builtin_nop", [], _ -> - emit (Pmov_rr (RAX,RAX)) - (* Catch-all *) - | _ -> - raise (Error ("unrecognized builtin " ^ name)) - -(* Calls to variadic functions for x86-64: register AL must contain - the number of XMM registers used for parameter passing. To be on - the safe side. do the same if the called function is - unprototyped. *) - -let set_al sg = - if Archi.ptr64 && (sg.sig_cc.cc_vararg || sg.sig_cc.cc_unproto) then begin - let (ir, fr, ofs) = next_arg_locations 0 0 0 sg.sig_args in - emit (Pmovl_ri (RAX, coqint_of_camlint (Int32.of_int fr))) - end - -(* Expansion of instructions *) - -let expand_instruction instr = - match instr with - | Pallocframe (sz, ofs_ra, ofs_link) -> - if Archi.ptr64 then begin - let (sz, save_regs) = sp_adjustment_64 sz in - (* Allocate frame *) - let sz' = Z.of_uint sz in - emit (Psubq_ri (RSP, sz')); - emit (Pcfi_adjust sz'); - if save_regs >= 0 then begin - (* Save the registers *) - emit (Pleaq (R10, linear_addr RSP (Z.of_uint save_regs))); - emit (Pcall_s (intern_string "__compcert_va_saveregs", - {sig_args = []; sig_res = None; sig_cc = cc_default})) - end; - (* Stack chaining *) - let fullsz = sz + 8 in - let addr1 = linear_addr RSP (Z.of_uint fullsz) in - let addr2 = linear_addr RSP ofs_link in - emit (Pleaq (RAX, addr1)); - emit (Pmovq_mr (addr2, RAX)); - current_function_stacksize := Int64.of_int fullsz - end else begin - let sz = sp_adjustment_32 sz in - (* Allocate frame *) - let sz' = Z.of_uint sz in - emit (Psubl_ri (RSP, sz')); - emit (Pcfi_adjust sz'); - (* Stack chaining *) - let addr1 = linear_addr RSP (Z.of_uint (sz + 4)) in - let addr2 = linear_addr RSP ofs_link in - emit (Pleal (RAX,addr1)); - emit (Pmovl_mr (addr2,RAX)); - PrintAsmaux.current_function_stacksize := Int32.of_int sz - end - | Pfreeframe(sz, ofs_ra, ofs_link) -> - if Archi.ptr64 then begin - let (sz, _) = sp_adjustment_64 sz in - emit (Paddq_ri (RSP, Z.of_uint sz)) - end else begin - let sz = sp_adjustment_32 sz in - emit (Paddl_ri (RSP, Z.of_uint sz)) - end - | Pjmp_s(_, sg) | Pjmp_r(_, sg) | Pcall_s(_, sg) | Pcall_r(_, sg) -> - set_al sg; - emit instr - | Pbuiltin (ef,args, res) -> - begin - match ef with - | EF_builtin(name, sg) -> - expand_builtin_inline (camlstring_of_coqstring name) args res - | EF_vload chunk -> - expand_builtin_vload chunk args res - | EF_vstore chunk -> - expand_builtin_vstore chunk args - | EF_memcpy(sz, al) -> - expand_builtin_memcpy (Z.to_int sz) (Z.to_int al) args - | EF_annot_val(txt, targ) -> - expand_annot_val txt targ args res - | EF_annot _ | EF_debug _ | EF_inline_asm _ -> - emit instr - | _ -> - assert false - end - | _ -> emit instr - -let int_reg_to_dwarf_32 = function - | RAX -> 0 - | RBX -> 3 - | RCX -> 1 - | RDX -> 2 - | RSI -> 6 - | RDI -> 7 - | RBP -> 5 - | RSP -> 4 - | _ -> assert false - -let int_reg_to_dwarf_64 = function - | RAX -> 0 - | RDX -> 1 - | RCX -> 2 - | RBX -> 3 - | RSI -> 4 - | RDI -> 5 - | RBP -> 6 - | RSP -> 7 - | R8 -> 8 - | R9 -> 9 - | R10 -> 10 - | R11 -> 11 - | R12 -> 12 - | R13 -> 13 - | R14 -> 14 - | R15 -> 15 - -let int_reg_to_dwarf = - if Archi.ptr64 then int_reg_to_dwarf_64 else int_reg_to_dwarf_32 - -let float_reg_to_dwarf_32 = function - | XMM0 -> 21 - | XMM1 -> 22 - | XMM2 -> 23 - | XMM3 -> 24 - | XMM4 -> 25 - | XMM5 -> 26 - | XMM6 -> 27 - | XMM7 -> 28 - | _ -> assert false - -let float_reg_to_dwarf_64 = function - | XMM0 -> 17 - | XMM1 -> 18 - | XMM2 -> 19 - | XMM3 -> 20 - | XMM4 -> 21 - | XMM5 -> 22 - | XMM6 -> 23 - | XMM7 -> 24 - | XMM8 -> 25 - | XMM9 -> 26 - | XMM10 -> 27 - | XMM11 -> 28 - | XMM12 -> 29 - | XMM13 -> 30 - | XMM14 -> 31 - | XMM15 -> 32 - -let float_reg_to_dwarf = - if Archi.ptr64 then float_reg_to_dwarf_64 else float_reg_to_dwarf_32 - -let preg_to_dwarf = function - | IR r -> int_reg_to_dwarf r - | FR r -> float_reg_to_dwarf r - | _ -> assert false - - -let expand_function id fn = - try - set_current_function fn; - if !Clflags.option_g then - expand_debug id 4 preg_to_dwarf expand_instruction fn.fn_code - else - List.iter expand_instruction fn.fn_code; - Errors.OK (get_current_function ()) - with Error s -> - Errors.Error (Errors.msg (coqstring_of_camlstring s)) - -let expand_fundef id = function - | Internal f -> - begin match expand_function id f with - | Errors.OK tf -> Errors.OK (Internal tf) - | Errors.Error msg -> Errors.Error msg - end - | External ef -> - Errors.OK (External ef) - -let expand_program (p: Asm.program) : Asm.program Errors.res = - AST.transform_partial_program2 expand_fundef (fun id v -> Errors.OK v) p diff --git a/ia32/Asmgen.v b/ia32/Asmgen.v deleted file mode 100644 index bb26d507..00000000 --- a/ia32/Asmgen.v +++ /dev/null @@ -1,754 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Translation from Mach to IA32 assembly language *) - -Require Import Coqlib Errors. -Require Import AST Integers Floats Memdata. -Require Import Op Locations Mach Asm. - -Open Local Scope string_scope. -Open Local Scope error_monad_scope. - -(** The code generation functions take advantage of several characteristics of the [Mach] code generated by earlier passes of the compiler: -- Argument and result registers are of the correct type. -- For two-address instructions, the result and the first argument - are in the same register. (True by construction in [RTLgen], and preserved by [Reload].) -- The top of the floating-point stack ([ST0], a.k.a. [FP0]) can only - appear in [mov] instructions, but never in arithmetic instructions. - -All these properties are true by construction, but it is painful to track them statically. Instead, we recheck them during code generation and fail if they do not hold. -*) - -(** Extracting integer or float registers. *) - -Definition ireg_of (r: mreg) : res ireg := - match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgen.ireg_of") end. - -Definition freg_of (r: mreg) : res freg := - match preg_of r with FR mr => OK mr | _ => Error(msg "Asmgen.freg_of") end. - -(** Smart constructors for some operations. *) - -Definition mk_mov (rd rs: preg) (k: code) : res code := - match rd, rs with - | IR rd, IR rs => OK (Pmov_rr rd rs :: k) - | FR rd, FR rs => OK (Pmovsd_ff rd rs :: k) - | _, _ => Error(msg "Asmgen.mk_mov") - end. - -Definition mk_shrximm (n: int) (k: code) : res code := - let p := Int.sub (Int.shl Int.one n) Int.one in - OK (Ptestl_rr RAX RAX :: - Pleal RCX (Addrmode (Some RAX) None (inl _ (Int.unsigned p))) :: - Pcmov Cond_l RAX RCX :: - Psarl_ri RAX n :: k). - -Definition mk_shrxlimm (n: int) (k: code) : res code := - OK (if Int.eq n Int.zero then Pmov_rr RAX RAX :: k else - Pcqto :: - Pshrq_ri RDX (Int.sub (Int.repr 64) n) :: - Pleaq RAX (Addrmode (Some RAX) (Some(RDX, 1)) (inl _ 0)) :: - Psarq_ri RAX n :: k). - -Definition low_ireg (r: ireg) : bool := - match r with RAX | RBX | RCX | RDX => true | _ => false end. - -Definition mk_intconv (mk: ireg -> ireg -> instruction) (rd rs: ireg) (k: code) := - if Archi.ptr64 || low_ireg rs then - OK (mk rd rs :: k) - else - OK (Pmov_rr RAX rs :: mk rd RAX :: k). - -Definition addressing_mentions (addr: addrmode) (r: ireg) : bool := - match addr with Addrmode base displ const => - match base with Some r' => ireg_eq r r' | None => false end - || match displ with Some(r', sc) => ireg_eq r r' | None => false end - end. - -Definition mk_storebyte (addr: addrmode) (rs: ireg) (k: code) := - if Archi.ptr64 || low_ireg rs then - OK (Pmovb_mr addr rs :: k) - else if addressing_mentions addr RAX then - OK (Pleal RCX addr :: Pmov_rr RAX rs :: - Pmovb_mr (Addrmode (Some RCX) None (inl _ 0)) RAX :: k) - else - OK (Pmov_rr RAX rs :: Pmovb_mr addr RAX :: k). - -(** Accessing slots in the stack frame. *) - -Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: code) := - let a := Addrmode (Some base) None (inl _ (Ptrofs.unsigned ofs)) in - match ty, preg_of dst with - | Tint, IR r => OK (Pmovl_rm r a :: k) - | Tlong, IR r => OK (Pmovq_rm r a :: k) - | Tsingle, FR r => OK (Pmovss_fm r a :: k) - | Tsingle, ST0 => OK (Pflds_m a :: k) - | Tfloat, FR r => OK (Pmovsd_fm r a :: k) - | Tfloat, ST0 => OK (Pfldl_m a :: k) - | Tany32, IR r => if Archi.ptr64 then Error (msg "Asmgen.loadind1") else OK (Pmov_rm_a r a :: k) - | Tany64, IR r => if Archi.ptr64 then OK (Pmov_rm_a r a :: k) else Error (msg "Asmgen.loadind2") - | Tany64, FR r => OK (Pmovsd_fm_a r a :: k) - | _, _ => Error (msg "Asmgen.loadind") - end. - -Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: code) := - let a := Addrmode (Some base) None (inl _ (Ptrofs.unsigned ofs)) in - match ty, preg_of src with - | Tint, IR r => OK (Pmovl_mr a r :: k) - | Tlong, IR r => OK (Pmovq_mr a r :: k) - | Tsingle, FR r => OK (Pmovss_mf a r :: k) - | Tsingle, ST0 => OK (Pfstps_m a :: k) - | Tfloat, FR r => OK (Pmovsd_mf a r :: k) - | Tfloat, ST0 => OK (Pfstpl_m a :: k) - | Tany32, IR r => if Archi.ptr64 then Error (msg "Asmgen.storeind1") else OK (Pmov_mr_a a r :: k) - | Tany64, IR r => if Archi.ptr64 then OK (Pmov_mr_a a r :: k) else Error (msg "Asmgen.storeind2") - | Tany64, FR r => OK (Pmovsd_mf_a a r :: k) - | _, _ => Error (msg "Asmgen.storeind") - end. - -(** Translation of addressing modes *) - -Definition transl_addressing (a: addressing) (args: list mreg): res addrmode := - match a, args with - | Aindexed n, a1 :: nil => - do r1 <- ireg_of a1; OK(Addrmode (Some r1) None (inl _ n)) - | Aindexed2 n, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK(Addrmode (Some r1) (Some(r2, 1)) (inl _ n)) - | Ascaled sc n, a1 :: nil => - do r1 <- ireg_of a1; OK(Addrmode None (Some(r1, sc)) (inl _ n)) - | Aindexed2scaled sc n, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK(Addrmode (Some r1) (Some(r2, sc)) (inl _ n)) - | Aglobal id ofs, nil => - OK(Addrmode None None (inr _ (id, ofs))) - | Abased id ofs, a1 :: nil => - do r1 <- ireg_of a1; OK(Addrmode (Some r1) None (inr _ (id, ofs))) - | Abasedscaled sc id ofs, a1 :: nil => - do r1 <- ireg_of a1; OK(Addrmode None (Some(r1, sc)) (inr _ (id, ofs))) - | Ainstack n, nil => - OK(Addrmode (Some RSP) None (inl _ (Ptrofs.signed n))) - | _, _ => - Error(msg "Asmgen.transl_addressing") - end. - -Definition normalize_addrmode_32 (a: addrmode) := - match a with - | Addrmode base ofs (inl n) => - Addrmode base ofs (inl _ (Int.signed (Int.repr n))) - | Addrmode base ofs (inr _) => - a - end. - -Definition normalize_addrmode_64 (a: addrmode) := - match a with - | Addrmode base ofs (inl n) => - let n' := Int.signed (Int.repr n) in - if zeq n' n - then (a, None) - else (Addrmode base ofs (inl _ 0), Some (Int64.repr n)) - | Addrmode base ofs (inr _) => - (a, None) - end. - -(** Floating-point comparison. We swap the operands in some cases - to simplify the handling of the unordered case. *) - -Definition floatcomp (cmp: comparison) (r1 r2: freg) : instruction := - match cmp with - | Clt | Cle => Pcomisd_ff r2 r1 - | Ceq | Cne | Cgt | Cge => Pcomisd_ff r1 r2 - end. - -Definition floatcomp32 (cmp: comparison) (r1 r2: freg) : instruction := - match cmp with - | Clt | Cle => Pcomiss_ff r2 r1 - | Ceq | Cne | Cgt | Cge => Pcomiss_ff r1 r2 - end. - -(** Translation of a condition. Prepends to [k] the instructions - that evaluate the condition and leave its boolean result in bits - of the condition register. *) - -Definition transl_cond - (cond: condition) (args: list mreg) (k: code) : res code := - match cond, args with - | Ccomp c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (Pcmpl_rr r1 r2 :: k) - | Ccompu c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (Pcmpl_rr r1 r2 :: k) - | Ccompimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (if Int.eq_dec n Int.zero then Ptestl_rr r1 r1 :: k else Pcmpl_ri r1 n :: k) - | Ccompuimm c n, a1 :: nil => - do r1 <- ireg_of a1; OK (Pcmpl_ri r1 n :: k) - | Ccompl c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (Pcmpq_rr r1 r2 :: k) - | Ccomplu c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (Pcmpq_rr r1 r2 :: k) - | Ccomplimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (if Int64.eq_dec n Int64.zero then Ptestq_rr r1 r1 :: k else Pcmpq_ri r1 n :: k) - | Ccompluimm c n, a1 :: nil => - do r1 <- ireg_of a1; OK (Pcmpq_ri r1 n :: k) - | Ccompf cmp, a1 :: a2 :: nil => - do r1 <- freg_of a1; do r2 <- freg_of a2; OK (floatcomp cmp r1 r2 :: k) - | Cnotcompf cmp, a1 :: a2 :: nil => - do r1 <- freg_of a1; do r2 <- freg_of a2; OK (floatcomp cmp r1 r2 :: k) - | Ccompfs cmp, a1 :: a2 :: nil => - do r1 <- freg_of a1; do r2 <- freg_of a2; OK (floatcomp32 cmp r1 r2 :: k) - | Cnotcompfs cmp, a1 :: a2 :: nil => - do r1 <- freg_of a1; do r2 <- freg_of a2; OK (floatcomp32 cmp r1 r2 :: k) - | Cmaskzero n, a1 :: nil => - do r1 <- ireg_of a1; OK (Ptestl_ri r1 n :: k) - | Cmasknotzero n, a1 :: nil => - do r1 <- ireg_of a1; OK (Ptestl_ri r1 n :: k) - | _, _ => - Error(msg "Asmgen.transl_cond") - end. - -(** What processor condition to test for a given Mach condition. *) - -Definition testcond_for_signed_comparison (cmp: comparison) := - match cmp with - | Ceq => Cond_e - | Cne => Cond_ne - | Clt => Cond_l - | Cle => Cond_le - | Cgt => Cond_g - | Cge => Cond_ge - end. - -Definition testcond_for_unsigned_comparison (cmp: comparison) := - match cmp with - | Ceq => Cond_e - | Cne => Cond_ne - | Clt => Cond_b - | Cle => Cond_be - | Cgt => Cond_a - | Cge => Cond_ae - end. - -Inductive extcond: Type := - | Cond_base (c: testcond) - | Cond_or (c1 c2: testcond) - | Cond_and (c1 c2: testcond). - -Definition testcond_for_condition (cond: condition) : extcond := - match cond with - | Ccomp c => Cond_base(testcond_for_signed_comparison c) - | Ccompu c => Cond_base(testcond_for_unsigned_comparison c) - | Ccompimm c n => Cond_base(testcond_for_signed_comparison c) - | Ccompuimm c n => Cond_base(testcond_for_unsigned_comparison c) - | Ccompl c => Cond_base(testcond_for_signed_comparison c) - | Ccomplu c => Cond_base(testcond_for_unsigned_comparison c) - | Ccomplimm c n => Cond_base(testcond_for_signed_comparison c) - | Ccompluimm c n => Cond_base(testcond_for_unsigned_comparison c) - | Ccompf c | Ccompfs c => - match c with - | Ceq => Cond_and Cond_np Cond_e - | Cne => Cond_or Cond_p Cond_ne - | Clt => Cond_base Cond_a - | Cle => Cond_base Cond_ae - | Cgt => Cond_base Cond_a - | Cge => Cond_base Cond_ae - end - | Cnotcompf c | Cnotcompfs c => - match c with - | Ceq => Cond_or Cond_p Cond_ne - | Cne => Cond_and Cond_np Cond_e - | Clt => Cond_base Cond_be - | Cle => Cond_base Cond_b - | Cgt => Cond_base Cond_be - | Cge => Cond_base Cond_b - end - | Cmaskzero n => Cond_base Cond_e - | Cmasknotzero n => Cond_base Cond_ne - end. - -(** Acting upon extended conditions. *) - -Definition mk_setcc_base (cond: extcond) (rd: ireg) (k: code) := - match cond with - | Cond_base c => - Psetcc c rd :: k - | Cond_and c1 c2 => - if ireg_eq rd RAX - then Psetcc c1 RAX :: Psetcc c2 RCX :: Pandl_rr RAX RCX :: k - else Psetcc c1 RAX :: Psetcc c2 rd :: Pandl_rr rd RAX :: k - | Cond_or c1 c2 => - if ireg_eq rd RAX - then Psetcc c1 RAX :: Psetcc c2 RCX :: Porl_rr RAX RCX :: k - else Psetcc c1 RAX :: Psetcc c2 rd :: Porl_rr rd RAX :: k - end. - -Definition mk_setcc (cond: extcond) (rd: ireg) (k: code) := - if Archi.ptr64 || low_ireg rd - then mk_setcc_base cond rd k - else mk_setcc_base cond RAX (Pmov_rr rd RAX :: k). - -Definition mk_jcc (cond: extcond) (lbl: label) (k: code) := - match cond with - | Cond_base c => Pjcc c lbl :: k - | Cond_and c1 c2 => Pjcc2 c1 c2 lbl :: k - | Cond_or c1 c2 => Pjcc c1 lbl :: Pjcc c2 lbl :: k - end. - -(** Translation of the arithmetic operation [r <- op(args)]. - The corresponding instructions are prepended to [k]. *) - -Definition transl_op - (op: operation) (args: list mreg) (res: mreg) (k: code) : Errors.res code := - match op, args with - | Omove, a1 :: nil => - mk_mov (preg_of res) (preg_of a1) k - | Ointconst n, nil => - do r <- ireg_of res; - OK ((if Int.eq_dec n Int.zero then Pxorl_r r else Pmovl_ri r n) :: k) - | Olongconst n, nil => - do r <- ireg_of res; - OK ((if Int64.eq_dec n Int64.zero then Pxorq_r r else Pmovq_ri r n) :: k) - | Ofloatconst f, nil => - do r <- freg_of res; - OK ((if Float.eq_dec f Float.zero then Pxorpd_f r else Pmovsd_fi r f) :: k) - | Osingleconst f, nil => - do r <- freg_of res; - OK ((if Float32.eq_dec f Float32.zero then Pxorps_f r else Pmovss_fi r f) :: k) - | Oindirectsymbol id, nil => - do r <- ireg_of res; - OK (Pmov_rs r id :: k) - | Ocast8signed, a1 :: nil => - do r1 <- ireg_of a1; do r <- ireg_of res; mk_intconv Pmovsb_rr r r1 k - | Ocast8unsigned, a1 :: nil => - do r1 <- ireg_of a1; do r <- ireg_of res; mk_intconv Pmovzb_rr r r1 k - | Ocast16signed, a1 :: nil => - do r1 <- ireg_of a1; do r <- ireg_of res; OK (Pmovsw_rr r r1 :: k) - | Ocast16unsigned, a1 :: nil => - do r1 <- ireg_of a1; do r <- ireg_of res; OK (Pmovzw_rr r r1 :: k) - | Oneg, a1 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Pnegl r :: k) - | Osub, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; do r2 <- ireg_of a2; OK (Psubl_rr r r2 :: k) - | Omul, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pimull_rr r r2 :: k) - | Omulimm n, a1 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Pimull_ri r n :: k) - | Omulhs, a1 :: a2 :: nil => - assertion (mreg_eq a1 AX); - assertion (mreg_eq res DX); - do r2 <- ireg_of a2; OK (Pimull_r r2 :: k) - | Omulhu, a1 :: a2 :: nil => - assertion (mreg_eq a1 AX); - assertion (mreg_eq res DX); - do r2 <- ireg_of a2; OK (Pmull_r r2 :: k) - | Odiv, a1 :: a2 :: nil => - assertion (mreg_eq a1 AX); - assertion (mreg_eq a2 CX); - assertion (mreg_eq res AX); - OK(Pcltd :: Pidivl RCX :: k) - | Odivu, a1 :: a2 :: nil => - assertion (mreg_eq a1 AX); - assertion (mreg_eq a2 CX); - assertion (mreg_eq res AX); - OK(Pxorl_r RDX :: Pdivl RCX :: k) - | Omod, a1 :: a2 :: nil => - assertion (mreg_eq a1 AX); - assertion (mreg_eq a2 CX); - assertion (mreg_eq res DX); - OK(Pcltd :: Pidivl RCX :: k) - | Omodu, a1 :: a2 :: nil => - assertion (mreg_eq a1 AX); - assertion (mreg_eq a2 CX); - assertion (mreg_eq res DX); - OK(Pxorl_r RDX :: Pdivl RCX :: k) - | Oand, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pandl_rr r r2 :: k) - | Oandimm n, a1 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Pandl_ri r n :: k) - | Oor, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; do r2 <- ireg_of a2; OK (Porl_rr r r2 :: k) - | Oorimm n, a1 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Porl_ri r n :: k) - | Oxor, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pxorl_rr r r2 :: k) - | Oxorimm n, a1 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Pxorl_ri r n :: k) - | Onot, a1 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Pnotl r :: k) - | Oshl, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - assertion (mreg_eq a2 CX); - do r <- ireg_of res; OK (Psall_rcl r :: k) - | Oshlimm n, a1 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Psall_ri r n :: k) - | Oshr, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - assertion (mreg_eq a2 CX); - do r <- ireg_of res; OK (Psarl_rcl r :: k) - | Oshrimm n, a1 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Psarl_ri r n :: k) - | Oshru, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - assertion (mreg_eq a2 CX); - do r <- ireg_of res; OK (Pshrl_rcl r :: k) - | Oshruimm n, a1 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Pshrl_ri r n :: k) - | Oshrximm n, a1 :: nil => - assertion (mreg_eq a1 AX); - assertion (mreg_eq res AX); - mk_shrximm n k - | Ororimm n, a1 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Prorl_ri r n :: k) - | Oshldimm n, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pshld_ri r r2 n :: k) - | Olea addr, _ => - do am <- transl_addressing addr args; do r <- ireg_of res; - OK (Pleal r (normalize_addrmode_32 am) :: k) -(* 64-bit integer operations *) - | Olowlong, a1 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Pmovls_rr r :: k) - | Ocast32signed, a1 :: nil => - do r1 <- ireg_of a1; do r <- ireg_of res; OK (Pmovsl_rr r r1 :: k) - | Ocast32unsigned, a1 :: nil => - do r1 <- ireg_of a1; do r <- ireg_of res; OK (Pmovzl_rr r r1 :: k) - | Onegl, a1 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Pnegq r :: k) - | Oaddlimm n, a1 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Paddq_ri r n :: k) - | Osubl, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; do r2 <- ireg_of a2; OK (Psubq_rr r r2 :: k) - | Omull, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pimulq_rr r r2 :: k) - | Omullimm n, a1 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Pimulq_ri r n :: k) - | Omullhs, a1 :: a2 :: nil => - assertion (mreg_eq a1 AX); - assertion (mreg_eq res DX); - do r2 <- ireg_of a2; OK (Pimulq_r r2 :: k) - | Omullhu, a1 :: a2 :: nil => - assertion (mreg_eq a1 AX); - assertion (mreg_eq res DX); - do r2 <- ireg_of a2; OK (Pmulq_r r2 :: k) - | Odivl, a1 :: a2 :: nil => - assertion (mreg_eq a1 AX); - assertion (mreg_eq a2 CX); - assertion (mreg_eq res AX); - OK(Pcqto :: Pidivq RCX :: k) - | Odivlu, a1 :: a2 :: nil => - assertion (mreg_eq a1 AX); - assertion (mreg_eq a2 CX); - assertion (mreg_eq res AX); - OK(Pxorq_r RDX :: Pdivq RCX :: k) - | Omodl, a1 :: a2 :: nil => - assertion (mreg_eq a1 AX); - assertion (mreg_eq a2 CX); - assertion (mreg_eq res DX); - OK(Pcqto :: Pidivq RCX :: k) - | Omodlu, a1 :: a2 :: nil => - assertion (mreg_eq a1 AX); - assertion (mreg_eq a2 CX); - assertion (mreg_eq res DX); - OK(Pxorq_r RDX :: Pdivq RCX :: k) - | Oandl, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pandq_rr r r2 :: k) - | Oandlimm n, a1 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Pandq_ri r n :: k) - | Oorl, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; do r2 <- ireg_of a2; OK (Porq_rr r r2 :: k) - | Oorlimm n, a1 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Porq_ri r n :: k) - | Oxorl, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; do r2 <- ireg_of a2; OK (Pxorq_rr r r2 :: k) - | Oxorlimm n, a1 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Pxorq_ri r n :: k) - | Onotl, a1 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Pnotq r :: k) - | Oshll, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - assertion (mreg_eq a2 CX); - do r <- ireg_of res; OK (Psalq_rcl r :: k) - | Oshllimm n, a1 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Psalq_ri r n :: k) - | Oshrl, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - assertion (mreg_eq a2 CX); - do r <- ireg_of res; OK (Psarq_rcl r :: k) - | Oshrlimm n, a1 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Psarq_ri r n :: k) - | Oshrxlimm n, a1 :: nil => - assertion (mreg_eq a1 AX); - assertion (mreg_eq res AX); - mk_shrxlimm n k - | Oshrlu, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - assertion (mreg_eq a2 CX); - do r <- ireg_of res; OK (Pshrq_rcl r :: k) - | Oshrluimm n, a1 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Pshrq_ri r n :: k) - | Ororlimm n, a1 :: nil => - assertion (mreg_eq a1 res); - do r <- ireg_of res; OK (Prorq_ri r n :: k) - | Oleal addr, _ => - do am <- transl_addressing addr args; do r <- ireg_of res; - OK (match normalize_addrmode_64 am with - | (am', None) => Pleaq r am' :: k - | (am', Some delta) => Pleaq r am' :: Paddq_ri r delta :: k - end) -(**) - | Onegf, a1 :: nil => - assertion (mreg_eq a1 res); - do r <- freg_of res; OK (Pnegd r :: k) - | Oabsf, a1 :: nil => - assertion (mreg_eq a1 res); - do r <- freg_of res; OK (Pabsd r :: k) - | Oaddf, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - do r <- freg_of res; do r2 <- freg_of a2; OK (Paddd_ff r r2 :: k) - | Osubf, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - do r <- freg_of res; do r2 <- freg_of a2; OK (Psubd_ff r r2 :: k) - | Omulf, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - do r <- freg_of res; do r2 <- freg_of a2; OK (Pmuld_ff r r2 :: k) - | Odivf, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - do r <- freg_of res; do r2 <- freg_of a2; OK (Pdivd_ff r r2 :: k) - | Onegfs, a1 :: nil => - assertion (mreg_eq a1 res); - do r <- freg_of res; OK (Pnegs r :: k) - | Oabsfs, a1 :: nil => - assertion (mreg_eq a1 res); - do r <- freg_of res; OK (Pabss r :: k) - | Oaddfs, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - do r <- freg_of res; do r2 <- freg_of a2; OK (Padds_ff r r2 :: k) - | Osubfs, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - do r <- freg_of res; do r2 <- freg_of a2; OK (Psubs_ff r r2 :: k) - | Omulfs, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - do r <- freg_of res; do r2 <- freg_of a2; OK (Pmuls_ff r r2 :: k) - | Odivfs, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - do r <- freg_of res; do r2 <- freg_of a2; OK (Pdivs_ff r r2 :: k) - | Osingleoffloat, a1 :: nil => - do r <- freg_of res; do r1 <- freg_of a1; OK (Pcvtsd2ss_ff r r1 :: k) - | Ofloatofsingle, a1 :: nil => - do r <- freg_of res; do r1 <- freg_of a1; OK (Pcvtss2sd_ff r r1 :: k) - | Ointoffloat, a1 :: nil => - do r <- ireg_of res; do r1 <- freg_of a1; OK (Pcvttsd2si_rf r r1 :: k) - | Ofloatofint, a1 :: nil => - do r <- freg_of res; do r1 <- ireg_of a1; OK (Pcvtsi2sd_fr r r1 :: k) - | Ointofsingle, a1 :: nil => - do r <- ireg_of res; do r1 <- freg_of a1; OK (Pcvttss2si_rf r r1 :: k) - | Osingleofint, a1 :: nil => - do r <- freg_of res; do r1 <- ireg_of a1; OK (Pcvtsi2ss_fr r r1 :: k) - | Olongoffloat, a1 :: nil => - do r <- ireg_of res; do r1 <- freg_of a1; OK (Pcvttsd2sl_rf r r1 :: k) - | Ofloatoflong, a1 :: nil => - do r <- freg_of res; do r1 <- ireg_of a1; OK (Pcvtsl2sd_fr r r1 :: k) - | Olongofsingle, a1 :: nil => - do r <- ireg_of res; do r1 <- freg_of a1; OK (Pcvttss2sl_rf r r1 :: k) - | Osingleoflong, a1 :: nil => - do r <- freg_of res; do r1 <- ireg_of a1; OK (Pcvtsl2ss_fr r r1 :: k) - | Ocmp c, args => - do r <- ireg_of res; - transl_cond c args (mk_setcc (testcond_for_condition c) r k) - | _, _ => - Error(msg "Asmgen.transl_op") - end. - -(** Translation of memory loads and stores *) - -Definition transl_load (chunk: memory_chunk) - (addr: addressing) (args: list mreg) (dest: mreg) - (k: code) : res code := - do am <- transl_addressing addr args; - match chunk with - | Mint8unsigned => - do r <- ireg_of dest; OK(Pmovzb_rm r am :: k) - | Mint8signed => - do r <- ireg_of dest; OK(Pmovsb_rm r am :: k) - | Mint16unsigned => - do r <- ireg_of dest; OK(Pmovzw_rm r am :: k) - | Mint16signed => - do r <- ireg_of dest; OK(Pmovsw_rm r am :: k) - | Mint32 => - do r <- ireg_of dest; OK(Pmovl_rm r am :: k) - | Mint64 => - do r <- ireg_of dest; OK(Pmovq_rm r am :: k) - | Mfloat32 => - do r <- freg_of dest; OK(Pmovss_fm r am :: k) - | Mfloat64 => - do r <- freg_of dest; OK(Pmovsd_fm r am :: k) - | _ => - Error (msg "Asmgen.transl_load") - end. - -Definition transl_store (chunk: memory_chunk) - (addr: addressing) (args: list mreg) (src: mreg) - (k: code) : res code := - do am <- transl_addressing addr args; - match chunk with - | Mint8unsigned | Mint8signed => - do r <- ireg_of src; mk_storebyte am r k - | Mint16unsigned | Mint16signed => - do r <- ireg_of src; OK(Pmovw_mr am r :: k) - | Mint32 => - do r <- ireg_of src; OK(Pmovl_mr am r :: k) - | Mint64 => - do r <- ireg_of src; OK(Pmovq_mr am r :: k) - | Mfloat32 => - do r <- freg_of src; OK(Pmovss_mf am r :: k) - | Mfloat64 => - do r <- freg_of src; OK(Pmovsd_mf am r :: k) - | _ => - Error (msg "Asmgen.transl_store") - end. - -(** Translation of a Mach instruction. *) - -Definition transl_instr (f: Mach.function) (i: Mach.instruction) - (ax_is_parent: bool) (k: code) := - match i with - | Mgetstack ofs ty dst => - loadind RSP ofs ty dst k - | Msetstack src ofs ty => - storeind src RSP ofs ty k - | Mgetparam ofs ty dst => - if ax_is_parent then - loadind RAX ofs ty dst k - else - (do k1 <- loadind RAX ofs ty dst k; - loadind RSP f.(fn_link_ofs) Tptr AX k1) - | Mop op args res => - transl_op op args res k - | Mload chunk addr args dst => - transl_load chunk addr args dst k - | Mstore chunk addr args src => - transl_store chunk addr args src k - | Mcall sig (inl reg) => - do r <- ireg_of reg; OK (Pcall_r r sig :: k) - | Mcall sig (inr symb) => - OK (Pcall_s symb sig :: k) - | Mtailcall sig (inl reg) => - do r <- ireg_of reg; - OK (Pfreeframe f.(fn_stacksize) f.(fn_retaddr_ofs) f.(fn_link_ofs) :: - Pjmp_r r sig :: k) - | Mtailcall sig (inr symb) => - OK (Pfreeframe f.(fn_stacksize) f.(fn_retaddr_ofs) f.(fn_link_ofs) :: - Pjmp_s symb sig :: k) - | Mlabel lbl => - OK(Plabel lbl :: k) - | Mgoto lbl => - OK(Pjmp_l lbl :: k) - | Mcond cond args lbl => - transl_cond cond args (mk_jcc (testcond_for_condition cond) lbl k) - | Mjumptable arg tbl => - do r <- ireg_of arg; OK (Pjmptbl r tbl :: k) - | Mreturn => - OK (Pfreeframe f.(fn_stacksize) f.(fn_retaddr_ofs) f.(fn_link_ofs) :: - Pret :: k) - | Mbuiltin ef args res => - OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) :: k) - end. - -(** Translation of a code sequence *) - -Definition it1_is_parent (before: bool) (i: Mach.instruction) : bool := - match i with - | Msetstack src ofs ty => before - | Mgetparam ofs ty dst => negb (mreg_eq dst AX) - | _ => false - end. - -(** This is the naive definition that we no longer use because it - is not tail-recursive. It is kept as specification. *) - -Fixpoint transl_code (f: Mach.function) (il: list Mach.instruction) (axp: bool) := - match il with - | nil => OK nil - | i1 :: il' => - do k <- transl_code f il' (it1_is_parent axp i1); - transl_instr f i1 axp k - end. - -(** This is an equivalent definition in continuation-passing style - that runs in constant stack space. *) - -Fixpoint transl_code_rec (f: Mach.function) (il: list Mach.instruction) - (axp: bool) (k: code -> res code) := - match il with - | nil => k nil - | i1 :: il' => - transl_code_rec f il' (it1_is_parent axp i1) - (fun c1 => do c2 <- transl_instr f i1 axp c1; k c2) - end. - -Definition transl_code' (f: Mach.function) (il: list Mach.instruction) (axp: bool) := - transl_code_rec f il axp (fun c => OK c). - -(** Translation of a whole function. Note that we must check - that the generated code contains less than [2^32] instructions, - otherwise the offset part of the [PC] code pointer could wrap - around, leading to incorrect executions. *) - -Definition transl_function (f: Mach.function) := - do c <- transl_code' f f.(Mach.fn_code) true; - OK (mkfunction f.(Mach.fn_sig) - (Pallocframe f.(fn_stacksize) f.(fn_retaddr_ofs) f.(fn_link_ofs) :: c)). - -Definition transf_function (f: Mach.function) : res Asm.function := - do tf <- transl_function f; - if zlt Ptrofs.max_unsigned (list_length_z tf.(fn_code)) - then Error (msg "code size exceeded") - else OK tf. - -Definition transf_fundef (f: Mach.fundef) : res Asm.fundef := - transf_partial_fundef transf_function f. - -Definition transf_program (p: Mach.program) : res Asm.program := - transform_partial_program transf_fundef p. - diff --git a/ia32/Asmgenproof.v b/ia32/Asmgenproof.v deleted file mode 100644 index e56dc429..00000000 --- a/ia32/Asmgenproof.v +++ /dev/null @@ -1,916 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Correctness proof for x86-64 generation: main proof. *) - -Require Import Coqlib Errors. -Require Import Integers Floats AST Linking. -Require Import Values Memory Events Globalenvs Smallstep. -Require Import Op Locations Mach Conventions Asm. -Require Import Asmgen Asmgenproof0 Asmgenproof1. - -Definition match_prog (p: Mach.program) (tp: Asm.program) := - match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. - -Lemma transf_program_match: - forall p tp, transf_program p = OK tp -> match_prog p tp. -Proof. - intros. eapply match_transform_partial_program; eauto. -Qed. - -Section PRESERVATION. - -Variable prog: Mach.program. -Variable tprog: Asm.program. -Hypothesis TRANSF: match_prog prog tprog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - -Lemma symbols_preserved: - forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof (Genv.find_symbol_match TRANSF). - -Lemma senv_preserved: - Senv.equiv ge tge. -Proof (Genv.senv_match TRANSF). - -Lemma functions_translated: - forall b f, - Genv.find_funct_ptr ge b = Some f -> - exists tf, - Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. -Proof (Genv.find_funct_ptr_transf_partial TRANSF). - -Lemma functions_transl: - forall fb f tf, - Genv.find_funct_ptr ge fb = Some (Internal f) -> - transf_function f = OK tf -> - Genv.find_funct_ptr tge fb = Some (Internal tf). -Proof. - intros. exploit functions_translated; eauto. intros [tf' [A B]]. - monadInv B. rewrite H0 in EQ; inv EQ; auto. -Qed. - -(** * Properties of control flow *) - -Lemma transf_function_no_overflow: - forall f tf, - transf_function f = OK tf -> list_length_z (fn_code tf) <= Ptrofs.max_unsigned. -Proof. - intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z (fn_code x))); monadInv EQ0. - omega. -Qed. - -Lemma exec_straight_exec: - forall fb f c ep tf tc c' rs m rs' m', - transl_code_at_pc ge (rs PC) fb f c ep tf tc -> - exec_straight tge tf tc rs m c' rs' m' -> - plus step tge (State rs m) E0 (State rs' m'). -Proof. - intros. inv H. - eapply exec_straight_steps_1; eauto. - eapply transf_function_no_overflow; eauto. - eapply functions_transl; eauto. -Qed. - -Lemma exec_straight_at: - forall fb f c ep tf tc c' ep' tc' rs m rs' m', - transl_code_at_pc ge (rs PC) fb f c ep tf tc -> - transl_code f c' ep' = OK tc' -> - exec_straight tge tf tc rs m tc' rs' m' -> - transl_code_at_pc ge (rs' PC) fb f c' ep' tf tc'. -Proof. - intros. inv H. - exploit exec_straight_steps_2; eauto. - eapply transf_function_no_overflow; eauto. - eapply functions_transl; eauto. - intros [ofs' [PC' CT']]. - rewrite PC'. constructor; auto. -Qed. - -(** The following lemmas show that the translation from Mach to Asm - preserves labels, in the sense that the following diagram commutes: -<< - translation - Mach code ------------------------ Asm instr sequence - | | - | Mach.find_label lbl find_label lbl | - | | - v v - Mach code tail ------------------- Asm instr seq tail - translation ->> - The proof demands many boring lemmas showing that Asm constructor - functions do not introduce new labels. - - In passing, we also prove a "is tail" property of the generated Asm code. -*) - -Section TRANSL_LABEL. - -Remark mk_mov_label: - forall rd rs k c, mk_mov rd rs k = OK c -> tail_nolabel k c. -Proof. - unfold mk_mov; intros. - destruct rd; try discriminate; destruct rs; TailNoLabel. -Qed. -Hint Resolve mk_mov_label: labels. - -Remark mk_shrximm_label: - forall n k c, mk_shrximm n k = OK c -> tail_nolabel k c. -Proof. - intros. monadInv H; TailNoLabel. -Qed. -Hint Resolve mk_shrximm_label: labels. - -Remark mk_shrxlimm_label: - forall n k c, mk_shrxlimm n k = OK c -> tail_nolabel k c. -Proof. - intros. monadInv H. destruct (Int.eq n Int.zero); TailNoLabel. -Qed. -Hint Resolve mk_shrxlimm_label: labels. - -Remark mk_intconv_label: - forall f r1 r2 k c, mk_intconv f r1 r2 k = OK c -> - (forall r r', nolabel (f r r')) -> - tail_nolabel k c. -Proof. - unfold mk_intconv; intros. TailNoLabel. -Qed. -Hint Resolve mk_intconv_label: labels. - -Remark mk_storebyte_label: - forall addr r k c, mk_storebyte addr r k = OK c -> tail_nolabel k c. -Proof. - unfold mk_storebyte; intros. TailNoLabel. -Qed. -Hint Resolve mk_storebyte_label: labels. - -Remark loadind_label: - forall base ofs ty dst k c, - loadind base ofs ty dst k = OK c -> - tail_nolabel k c. -Proof. - unfold loadind; intros. destruct ty; try discriminate; destruct (preg_of dst); TailNoLabel. -Qed. - -Remark storeind_label: - forall base ofs ty src k c, - storeind src base ofs ty k = OK c -> - tail_nolabel k c. -Proof. - unfold storeind; intros. destruct ty; try discriminate; destruct (preg_of src); TailNoLabel. -Qed. - -Remark mk_setcc_base_label: - forall xc rd k, - tail_nolabel k (mk_setcc_base xc rd k). -Proof. - intros. destruct xc; simpl; destruct (ireg_eq rd RAX); TailNoLabel. -Qed. - -Remark mk_setcc_label: - forall xc rd k, - tail_nolabel k (mk_setcc xc rd k). -Proof. - intros. unfold mk_setcc. destruct (Archi.ptr64 || low_ireg rd). - apply mk_setcc_base_label. - eapply tail_nolabel_trans. apply mk_setcc_base_label. TailNoLabel. -Qed. - -Remark mk_jcc_label: - forall xc lbl' k, - tail_nolabel k (mk_jcc xc lbl' k). -Proof. - intros. destruct xc; simpl; TailNoLabel. -Qed. - -Remark transl_cond_label: - forall cond args k c, - transl_cond cond args k = OK c -> - tail_nolabel k c. -Proof. - unfold transl_cond; intros. - destruct cond; TailNoLabel. - destruct (Int.eq_dec n Int.zero); TailNoLabel. - destruct (Int64.eq_dec n Int64.zero); TailNoLabel. - destruct c0; simpl; TailNoLabel. - destruct c0; simpl; TailNoLabel. - destruct c0; simpl; TailNoLabel. - destruct c0; simpl; TailNoLabel. -Qed. - -Remark transl_op_label: - forall op args r k c, - transl_op op args r k = OK c -> - tail_nolabel k c. -Proof. - unfold transl_op; intros. destruct op; TailNoLabel. - destruct (Int.eq_dec n Int.zero); TailNoLabel. - destruct (Int64.eq_dec n Int64.zero); TailNoLabel. - destruct (Float.eq_dec n Float.zero); TailNoLabel. - destruct (Float32.eq_dec n Float32.zero); TailNoLabel. - destruct (normalize_addrmode_64 x) as [am' [delta|]]; TailNoLabel. - eapply tail_nolabel_trans. eapply transl_cond_label; eauto. eapply mk_setcc_label. -Qed. - -Remark transl_load_label: - forall chunk addr args dest k c, - transl_load chunk addr args dest k = OK c -> - tail_nolabel k c. -Proof. - intros. monadInv H. destruct chunk; TailNoLabel. -Qed. - -Remark transl_store_label: - forall chunk addr args src k c, - transl_store chunk addr args src k = OK c -> - tail_nolabel k c. -Proof. - intros. monadInv H. destruct chunk; TailNoLabel. -Qed. - -Lemma transl_instr_label: - forall f i ep k c, - transl_instr f i ep k = OK c -> - match i with Mlabel lbl => c = Plabel lbl :: k | _ => tail_nolabel k c end. -Proof. -Opaque loadind. - unfold transl_instr; intros; destruct i; TailNoLabel. - eapply loadind_label; eauto. - eapply storeind_label; eauto. - eapply loadind_label; eauto. - eapply tail_nolabel_trans; eapply loadind_label; eauto. - eapply transl_op_label; eauto. - eapply transl_load_label; eauto. - eapply transl_store_label; eauto. - destruct s0; TailNoLabel. - destruct s0; TailNoLabel. - eapply tail_nolabel_trans. eapply transl_cond_label; eauto. eapply mk_jcc_label. -Qed. - -Lemma transl_instr_label': - forall lbl f i ep k c, - transl_instr f i ep k = OK c -> - find_label lbl c = if Mach.is_label lbl i then Some k else find_label lbl k. -Proof. - intros. exploit transl_instr_label; eauto. - destruct i; try (intros [A B]; apply B). - intros. subst c. simpl. auto. -Qed. - -Lemma transl_code_label: - forall lbl f c ep tc, - transl_code f c ep = OK tc -> - match Mach.find_label lbl c with - | None => find_label lbl tc = None - | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_code f c' false = OK tc' - end. -Proof. - induction c; simpl; intros. - inv H. auto. - monadInv H. rewrite (transl_instr_label' lbl _ _ _ _ _ EQ0). - generalize (Mach.is_label_correct lbl a). - destruct (Mach.is_label lbl a); intros. - subst a. simpl in EQ. exists x; auto. - eapply IHc; eauto. -Qed. - -Lemma transl_find_label: - forall lbl f tf, - transf_function f = OK tf -> - match Mach.find_label lbl f.(Mach.fn_code) with - | None => find_label lbl tf.(fn_code) = None - | Some c => exists tc, find_label lbl tf.(fn_code) = Some tc /\ transl_code f c false = OK tc - end. -Proof. - intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z (fn_code x))); inv EQ0. - monadInv EQ. simpl. eapply transl_code_label; eauto. rewrite transl_code'_transl_code in EQ0; eauto. -Qed. - -End TRANSL_LABEL. - -(** A valid branch in a piece of Mach code translates to a valid ``go to'' - transition in the generated PPC code. *) - -Lemma find_label_goto_label: - forall f tf lbl rs m c' b ofs, - Genv.find_funct_ptr ge b = Some (Internal f) -> - transf_function f = OK tf -> - rs PC = Vptr b ofs -> - Mach.find_label lbl f.(Mach.fn_code) = Some c' -> - exists tc', exists rs', - goto_label tf lbl rs m = Next rs' m - /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc' - /\ forall r, r <> PC -> rs'#r = rs#r. -Proof. - intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2. - intros [tc [A B]]. - exploit label_pos_code_tail; eauto. instantiate (1 := 0). - intros [pos' [P [Q R]]]. - exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))). - split. unfold goto_label. rewrite P. rewrite H1. auto. - split. rewrite Pregmap.gss. constructor; auto. - rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. - auto. omega. - generalize (transf_function_no_overflow _ _ H0). omega. - intros. apply Pregmap.gso; auto. -Qed. - -(** Existence of return addresses *) - -Lemma return_address_exists: - forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) -> - exists ra, return_address_offset f c ra. -Proof. - intros. eapply Asmgenproof0.return_address_exists; eauto. -- intros. exploit transl_instr_label; eauto. - destruct i; try (intros [A B]; apply A). intros. subst c0. repeat constructor. -- intros. monadInv H0. - destruct (zlt Ptrofs.max_unsigned (list_length_z (fn_code x))); inv EQ0. - monadInv EQ. rewrite transl_code'_transl_code in EQ0. - exists x; exists true; split; auto. unfold fn_code. repeat constructor. -- exact transf_function_no_overflow. -Qed. - -(** * Proof of semantic preservation *) - -(** Semantic preservation is proved using simulation diagrams - of the following form. -<< - st1 --------------- st2 - | | - t| *|t - | | - v v - st1'--------------- st2' ->> - The invariant is the [match_states] predicate below, which includes: -- The PPC code pointed by the PC register is the translation of - the current Mach code sequence. -- Mach register values and PPC register values agree. -*) - -Inductive match_states: Mach.state -> Asm.state -> Prop := - | match_states_intro: - forall s fb sp c ep ms m m' rs f tf tc - (STACKS: match_stack ge s) - (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) - (MEXT: Mem.extends m m') - (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc) - (AG: agree ms sp rs) - (AXP: ep = true -> rs#RAX = parent_sp s), - match_states (Mach.State s fb sp c ms m) - (Asm.State rs m') - | match_states_call: - forall s fb ms m m' rs - (STACKS: match_stack ge s) - (MEXT: Mem.extends m m') - (AG: agree ms (parent_sp s) rs) - (ATPC: rs PC = Vptr fb Ptrofs.zero) - (ATLR: rs RA = parent_ra s), - match_states (Mach.Callstate s fb ms m) - (Asm.State rs m') - | match_states_return: - forall s ms m m' rs - (STACKS: match_stack ge s) - (MEXT: Mem.extends m m') - (AG: agree ms (parent_sp s) rs) - (ATPC: rs PC = parent_ra s), - match_states (Mach.Returnstate s ms m) - (Asm.State rs m'). - -Lemma exec_straight_steps: - forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2, - match_stack ge s -> - Mem.extends m2 m2' -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> - (forall k c (TR: transl_instr f i ep k = OK c), - exists rs2, - exec_straight tge tf c rs1 m1' k rs2 m2' - /\ agree ms2 sp rs2 - /\ (it1_is_parent ep i = true -> rs2#RAX = parent_sp s)) -> - exists st', - plus step tge (State rs1 m1') E0 st' /\ - match_states (Mach.State s fb sp c ms2 m2) st'. -Proof. - intros. inversion H2. subst. monadInv H7. - exploit H3; eauto. intros [rs2 [A [B C]]]. - exists (State rs2 m2'); split. - eapply exec_straight_exec; eauto. - econstructor; eauto. eapply exec_straight_at; eauto. -Qed. - -Lemma exec_straight_steps_goto: - forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c', - match_stack ge s -> - Mem.extends m2 m2' -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - Mach.find_label lbl f.(Mach.fn_code) = Some c' -> - transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc -> - it1_is_parent ep i = false -> - (forall k c (TR: transl_instr f i ep k = OK c), - exists jmp, exists k', exists rs2, - exec_straight tge tf c rs1 m1' (jmp :: k') rs2 m2' - /\ agree ms2 sp rs2 - /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') -> - exists st', - plus step tge (State rs1 m1') E0 st' /\ - match_states (Mach.State s fb sp c' ms2 m2) st'. -Proof. - intros. inversion H3. subst. monadInv H9. - exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]]. - generalize (functions_transl _ _ _ H7 H8); intro FN. - generalize (transf_function_no_overflow _ _ H8); intro NOOV. - exploit exec_straight_steps_2; eauto. - intros [ofs' [PC2 CT2]]. - exploit find_label_goto_label; eauto. - intros [tc' [rs3 [GOTO [AT' OTH]]]]. - exists (State rs3 m2'); split. - eapply plus_right'. - eapply exec_straight_steps_1; eauto. - econstructor; eauto. - eapply find_instr_tail. eauto. - rewrite C. eexact GOTO. - traceEq. - econstructor; eauto. - apply agree_exten with rs2; auto with asmgen. - congruence. -Qed. - -(** We need to show that, in the simulation diagram, we cannot - take infinitely many Mach transitions that correspond to zero - transitions on the PPC side. Actually, all Mach transitions - correspond to at least one Asm transition, except the - transition from [Mach.Returnstate] to [Mach.State]. - So, the following integer measure will suffice to rule out - the unwanted behaviour. *) - -Definition measure (s: Mach.state) : nat := - match s with - | Mach.State _ _ _ _ _ _ => 0%nat - | Mach.Callstate _ _ _ _ => 0%nat - | Mach.Returnstate _ _ _ => 1%nat - end. - -(** This is the simulation diagram. We prove it by case analysis on the Mach transition. *) - -Theorem step_simulation: - forall S1 t S2, Mach.step return_address_offset ge S1 t S2 -> - forall S1' (MS: match_states S1 S1'), - (exists S2', plus step tge S1' t S2' /\ match_states S2 S2') - \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat. -Proof. - induction 1; intros; inv MS. - -- (* Mlabel *) - left; eapply exec_straight_steps; eauto; intros. - monadInv TR. econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split. apply agree_nextinstr; auto. simpl; congruence. - -- (* Mgetstack *) - unfold load_stack in H. - exploit Mem.loadv_extends; eauto. intros [v' [A B]]. - rewrite (sp_val _ _ _ AG) in A. - left; eapply exec_straight_steps; eauto. intros. simpl in TR. - exploit loadind_correct; eauto. intros [rs' [P [Q R]]]. - exists rs'; split. eauto. - split. eapply agree_set_mreg; eauto. congruence. - simpl; congruence. - -- (* Msetstack *) - unfold store_stack in H. - assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto. - exploit Mem.storev_extends; eauto. intros [m2' [A B]]. - left; eapply exec_straight_steps; eauto. - rewrite (sp_val _ _ _ AG) in A. intros. simpl in TR. - exploit storeind_correct; eauto. intros [rs' [P Q]]. - exists rs'; split. eauto. - split. eapply agree_undef_regs; eauto. - simpl; intros. rewrite Q; auto with asmgen. -Local Transparent destroyed_by_setstack. - destruct ty; simpl; intuition congruence. - -- (* Mgetparam *) - assert (f0 = f) by congruence; subst f0. - unfold load_stack in *. - exploit Mem.loadv_extends. eauto. eexact H0. auto. - intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A. - exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'. - exploit Mem.loadv_extends. eauto. eexact H1. auto. - intros [v' [C D]]. -Opaque loadind. - left; eapply exec_straight_steps; eauto; intros. - assert (DIFF: negb (mreg_eq dst AX) = true -> IR RAX <> preg_of dst). - intros. change (IR RAX) with (preg_of AX). red; intros. - unfold proj_sumbool in H1. destruct (mreg_eq dst AX); try discriminate. - elim n. eapply preg_of_injective; eauto. - destruct ep; simpl in TR. -(* RAX contains parent *) - exploit loadind_correct. eexact TR. - instantiate (2 := rs0). rewrite AXP; eauto. - intros [rs1 [P [Q R]]]. - exists rs1; split. eauto. - split. eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto. - simpl; intros. rewrite R; auto. -(* RAX does not contain parent *) - monadInv TR. - exploit loadind_correct. eexact EQ0. eauto. intros [rs1 [P [Q R]]]. simpl in Q. - exploit loadind_correct. eexact EQ. instantiate (2 := rs1). rewrite Q. eauto. - intros [rs2 [S [T U]]]. - exists rs2; split. eapply exec_straight_trans; eauto. - split. eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto. - simpl; intros. rewrite U; auto. - -- (* Mop *) - assert (eval_operation tge sp op rs##args m = Some v). - rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. - exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. eexact H0. - intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. - left; eapply exec_straight_steps; eauto; intros. simpl in TR. - exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]]. - assert (S: Val.lessdef v (rs2 (preg_of res))) by (eapply Val.lessdef_trans; eauto). - exists rs2; split. eauto. - split. eapply agree_set_undef_mreg; eauto. - simpl; congruence. - -- (* Mload *) - assert (eval_addressing tge sp addr rs##args = Some a). - rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. - intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. - exploit Mem.loadv_extends; eauto. intros [v' [C D]]. - left; eapply exec_straight_steps; eauto; intros. simpl in TR. - exploit transl_load_correct; eauto. intros [rs2 [P [Q R]]]. - exists rs2; split. eauto. - split. eapply agree_set_undef_mreg; eauto. congruence. - simpl; congruence. - -- (* Mstore *) - assert (eval_addressing tge sp addr rs##args = Some a). - rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. - intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. - assert (Val.lessdef (rs src) (rs0 (preg_of src))). eapply preg_val; eauto. - exploit Mem.storev_extends; eauto. intros [m2' [C D]]. - left; eapply exec_straight_steps; eauto. - intros. simpl in TR. - exploit transl_store_correct; eauto. intros [rs2 [P Q]]. - exists rs2; split. eauto. - split. eapply agree_undef_regs; eauto. - simpl; congruence. - -- (* Mcall *) - assert (f0 = f) by congruence. subst f0. - inv AT. - assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - destruct ros as [rf|fid]; simpl in H; monadInv H5. -+ (* Indirect call *) - assert (rs rf = Vptr f' Ptrofs.zero). - destruct (rs rf); try discriminate. - revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. - assert (rs0 x0 = Vptr f' Ptrofs.zero). - exploit ireg_val; eauto. rewrite H5; intros LD; inv LD; auto. - generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. - assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). - econstructor; eauto. - exploit return_address_offset_correct; eauto. intros; subst ra. - left; econstructor; split. - apply plus_one. eapply exec_step_internal. eauto. - eapply functions_transl; eauto. eapply find_instr_tail; eauto. - simpl. eauto. - econstructor; eauto. - econstructor; eauto. - eapply agree_sp_def; eauto. - simpl. eapply agree_exten; eauto. intros. Simplifs. - Simplifs. rewrite <- H2. auto. -+ (* Direct call *) - generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. - assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x). - econstructor; eauto. - exploit return_address_offset_correct; eauto. intros; subst ra. - left; econstructor; split. - apply plus_one. eapply exec_step_internal. eauto. - eapply functions_transl; eauto. eapply find_instr_tail; eauto. - simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. eauto. - econstructor; eauto. - econstructor; eauto. - eapply agree_sp_def; eauto. - simpl. eapply agree_exten; eauto. intros. Simplifs. - Simplifs. rewrite <- H2. auto. - -- (* Mtailcall *) - assert (f0 = f) by congruence. subst f0. - inv AT. - assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - rewrite (sp_val _ _ _ AG) in *. unfold load_stack in *. - exploit Mem.loadv_extends. eauto. eexact H1. auto. simpl. intros [parent' [A B]]. - exploit Mem.loadv_extends. eauto. eexact H2. auto. simpl. intros [ra' [C D]]. - exploit lessdef_parent_sp; eauto. intros. subst parent'. clear B. - exploit lessdef_parent_ra; eauto. intros. subst ra'. clear D. - exploit Mem.free_parallel_extends; eauto. intros [m2' [E F]]. - destruct ros as [rf|fid]; simpl in H; monadInv H7. -+ (* Indirect call *) - assert (rs rf = Vptr f' Ptrofs.zero). - destruct (rs rf); try discriminate. - revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. - assert (rs0 x0 = Vptr f' Ptrofs.zero). - exploit ireg_val; eauto. rewrite H7; intros LD; inv LD; auto. - generalize (code_tail_next_int _ _ _ _ NOOV H8). intro CT1. - left; econstructor; split. - eapply plus_left. eapply exec_step_internal. eauto. - eapply functions_transl; eauto. eapply find_instr_tail; eauto. - simpl. replace (chunk_of_type Tptr) with Mptr in * by (unfold Tptr, Mptr; destruct Archi.ptr64; auto). - rewrite C. rewrite A. rewrite <- (sp_val _ _ _ AG). rewrite E. eauto. - apply star_one. eapply exec_step_internal. - transitivity (Val.offset_ptr rs0#PC Ptrofs.one). auto. rewrite <- H4. simpl. eauto. - eapply functions_transl; eauto. eapply find_instr_tail; eauto. - simpl. eauto. traceEq. - econstructor; eauto. - apply agree_set_other; auto. apply agree_nextinstr. apply agree_set_other; auto. - eapply agree_change_sp; eauto. eapply parent_sp_def; eauto. - Simplifs. rewrite Pregmap.gso; auto. - generalize (preg_of_not_SP rf). rewrite (ireg_of_eq _ _ EQ1). congruence. -+ (* Direct call *) - generalize (code_tail_next_int _ _ _ _ NOOV H8). intro CT1. - left; econstructor; split. - eapply plus_left. eapply exec_step_internal. eauto. - eapply functions_transl; eauto. eapply find_instr_tail; eauto. - simpl. replace (chunk_of_type Tptr) with Mptr in * by (unfold Tptr, Mptr; destruct Archi.ptr64; auto). - rewrite C. rewrite A. rewrite <- (sp_val _ _ _ AG). rewrite E. eauto. - apply star_one. eapply exec_step_internal. - transitivity (Val.offset_ptr rs0#PC Ptrofs.one). auto. rewrite <- H4. simpl. eauto. - eapply functions_transl; eauto. eapply find_instr_tail; eauto. - simpl. eauto. traceEq. - econstructor; eauto. - apply agree_set_other; auto. apply agree_nextinstr. apply agree_set_other; auto. - eapply agree_change_sp; eauto. eapply parent_sp_def; eauto. - rewrite Pregmap.gss. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. auto. - -- (* Mbuiltin *) - inv AT. monadInv H4. - exploit functions_transl; eauto. intro FN. - generalize (transf_function_no_overflow _ _ H3); intro NOOV. - exploit builtin_args_match; eauto. intros [vargs' [P Q]]. - exploit external_call_mem_extends; eauto. - intros [vres' [m2' [A [B [C D]]]]]. - left. econstructor; split. apply plus_one. - eapply exec_step_builtin. eauto. eauto. - eapply find_instr_tail; eauto. - erewrite <- sp_val by eauto. - eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. - eauto. - econstructor; eauto. - instantiate (2 := tf); instantiate (1 := x). - unfold nextinstr_nf, nextinstr. rewrite Pregmap.gss. - rewrite undef_regs_other. rewrite set_res_other. rewrite undef_regs_other_2. - rewrite <- H1. simpl. econstructor; eauto. - eapply code_tail_next_int; eauto. - rewrite preg_notin_charact. intros. auto with asmgen. - auto with asmgen. - simpl; intros. intuition congruence. - apply agree_nextinstr_nf. eapply agree_set_res; auto. - eapply agree_undef_regs; eauto. intros; apply undef_regs_other_2; auto. - congruence. - -- (* Mgoto *) - assert (f0 = f) by congruence. subst f0. - inv AT. monadInv H4. - exploit find_label_goto_label; eauto. intros [tc' [rs' [GOTO [AT2 INV]]]]. - left; exists (State rs' m'); split. - apply plus_one. econstructor; eauto. - eapply functions_transl; eauto. - eapply find_instr_tail; eauto. - simpl; eauto. - econstructor; eauto. - eapply agree_exten; eauto with asmgen. - congruence. - -- (* Mcond true *) - assert (f0 = f) by congruence. subst f0. - exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. - left; eapply exec_straight_steps_goto; eauto. - intros. simpl in TR. - destruct (transl_cond_correct tge tf cond args _ _ rs0 m' TR) - as [rs' [A [B C]]]. - rewrite EC in B. - destruct (testcond_for_condition cond); simpl in *. -(* simple jcc *) - exists (Pjcc c1 lbl); exists k; exists rs'. - split. eexact A. - split. eapply agree_exten; eauto. - simpl. rewrite B. auto. -(* jcc; jcc *) - destruct (eval_testcond c1 rs') as [b1|] eqn:TC1; - destruct (eval_testcond c2 rs') as [b2|] eqn:TC2; inv B. - destruct b1. - (* first jcc jumps *) - exists (Pjcc c1 lbl); exists (Pjcc c2 lbl :: k); exists rs'. - split. eexact A. - split. eapply agree_exten; eauto. - simpl. rewrite TC1. auto. - (* second jcc jumps *) - exists (Pjcc c2 lbl); exists k; exists (nextinstr rs'). - split. eapply exec_straight_trans. eexact A. - eapply exec_straight_one. simpl. rewrite TC1. auto. auto. - split. eapply agree_exten; eauto. - intros; Simplifs. - simpl. rewrite eval_testcond_nextinstr. rewrite TC2. - destruct b2; auto || discriminate. -(* jcc2 *) - destruct (eval_testcond c1 rs') as [b1|] eqn:TC1; - destruct (eval_testcond c2 rs') as [b2|] eqn:TC2; inv B. - destruct (andb_prop _ _ H3). subst. - exists (Pjcc2 c1 c2 lbl); exists k; exists rs'. - split. eexact A. - split. eapply agree_exten; eauto. - simpl. rewrite TC1; rewrite TC2; auto. - -- (* Mcond false *) - exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC. - left; eapply exec_straight_steps; eauto. intros. simpl in TR. - destruct (transl_cond_correct tge tf cond args _ _ rs0 m' TR) - as [rs' [A [B C]]]. - rewrite EC in B. - destruct (testcond_for_condition cond); simpl in *. -(* simple jcc *) - econstructor; split. - eapply exec_straight_trans. eexact A. - apply exec_straight_one. simpl. rewrite B. eauto. auto. - split. apply agree_nextinstr. eapply agree_exten; eauto. - simpl; congruence. -(* jcc ; jcc *) - destruct (eval_testcond c1 rs') as [b1|] eqn:TC1; - destruct (eval_testcond c2 rs') as [b2|] eqn:TC2; inv B. - destruct (orb_false_elim _ _ H1); subst. - econstructor; split. - eapply exec_straight_trans. eexact A. - eapply exec_straight_two. simpl. rewrite TC1. eauto. auto. - simpl. rewrite eval_testcond_nextinstr. rewrite TC2. eauto. auto. auto. - split. apply agree_nextinstr. apply agree_nextinstr. eapply agree_exten; eauto. - simpl; congruence. -(* jcc2 *) - destruct (eval_testcond c1 rs') as [b1|] eqn:TC1; - destruct (eval_testcond c2 rs') as [b2|] eqn:TC2; inv B. - exists (nextinstr rs'); split. - eapply exec_straight_trans. eexact A. - apply exec_straight_one. simpl. - rewrite TC1; rewrite TC2. - destruct b1. simpl in *. subst b2. auto. auto. - auto. - split. apply agree_nextinstr. eapply agree_exten; eauto. - rewrite H1; congruence. - -- (* Mjumptable *) - assert (f0 = f) by congruence. subst f0. - inv AT. monadInv H6. - exploit functions_transl; eauto. intro FN. - generalize (transf_function_no_overflow _ _ H5); intro NOOV. - set (rs1 := rs0 #RAX <- Vundef #RDX <- Vundef). - exploit (find_label_goto_label f tf lbl rs1); eauto. - intros [tc' [rs' [A [B C]]]]. - exploit ireg_val; eauto. rewrite H. intros LD; inv LD. - left; econstructor; split. - apply plus_one. econstructor; eauto. - eapply find_instr_tail; eauto. - simpl. rewrite <- H9. unfold Mach.label in H0; unfold label; rewrite H0. eexact A. - econstructor; eauto. -Transparent destroyed_by_jumptable. - apply agree_undef_regs with rs0; auto. - simpl; intros. destruct H8. rewrite C by auto with asmgen. unfold rs1; Simplifs. - congruence. - -- (* Mreturn *) - assert (f0 = f) by congruence. subst f0. - inv AT. - assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - rewrite (sp_val _ _ _ AG) in *. unfold load_stack in *. - replace (chunk_of_type Tptr) with Mptr in * by (unfold Tptr, Mptr; destruct Archi.ptr64; auto). - exploit Mem.loadv_extends. eauto. eexact H0. auto. simpl. intros [parent' [A B]]. - exploit lessdef_parent_sp; eauto. intros. subst parent'. clear B. - exploit Mem.loadv_extends. eauto. eexact H1. auto. simpl. intros [ra' [C D]]. - exploit lessdef_parent_ra; eauto. intros. subst ra'. clear D. - exploit Mem.free_parallel_extends; eauto. intros [m2' [E F]]. - monadInv H6. - exploit code_tail_next_int; eauto. intro CT1. - left; econstructor; split. - eapply plus_left. eapply exec_step_internal. eauto. - eapply functions_transl; eauto. eapply find_instr_tail; eauto. - simpl. rewrite C. rewrite A. rewrite <- (sp_val _ _ _ AG). rewrite E. eauto. - apply star_one. eapply exec_step_internal. - transitivity (Val.offset_ptr rs0#PC Ptrofs.one). auto. rewrite <- H3. simpl. eauto. - eapply functions_transl; eauto. eapply find_instr_tail; eauto. - simpl. eauto. traceEq. - constructor; auto. - apply agree_set_other; auto. apply agree_nextinstr. apply agree_set_other; auto. - eapply agree_change_sp; eauto. eapply parent_sp_def; eauto. - -- (* internal function *) - exploit functions_translated; eauto. intros [tf [A B]]. monadInv B. - generalize EQ; intros EQ'. monadInv EQ'. - destruct (zlt Ptrofs.max_unsigned (list_length_z (fn_code x0))); inv EQ1. - monadInv EQ0. rewrite transl_code'_transl_code in EQ1. - unfold store_stack in *. - exploit Mem.alloc_extends. eauto. eauto. apply Zle_refl. apply Zle_refl. - intros [m1' [C D]]. - exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto. - intros [m2' [F G]]. - exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto. - intros [m3' [P Q]]. - left; econstructor; split. - apply plus_one. econstructor; eauto. - simpl. rewrite Ptrofs.unsigned_zero. simpl. eauto. - simpl. rewrite C. simpl in F, P. - replace (chunk_of_type Tptr) with Mptr in F, P by (unfold Tptr, Mptr; destruct Archi.ptr64; auto). - rewrite (sp_val _ _ _ AG) in F. rewrite F. - rewrite ATLR. rewrite P. eauto. - econstructor; eauto. - unfold nextinstr. rewrite Pregmap.gss. repeat rewrite Pregmap.gso; auto with asmgen. - rewrite ATPC. simpl. constructor; eauto. - unfold fn_code. eapply code_tail_next_int. simpl in g. omega. - constructor. - apply agree_nextinstr. eapply agree_change_sp; eauto. -Transparent destroyed_at_function_entry. - apply agree_undef_regs with rs0; eauto. - simpl; intros. apply Pregmap.gso; auto with asmgen. tauto. - congruence. - intros. Simplifs. eapply agree_sp; eauto. - -- (* external function *) - exploit functions_translated; eauto. - intros [tf [A B]]. simpl in B. inv B. - exploit extcall_arguments_match; eauto. - intros [args' [C D]]. - exploit external_call_mem_extends; eauto. - intros [res' [m2' [P [Q [R S]]]]]. - left; econstructor; split. - apply plus_one. eapply exec_step_external; eauto. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. - econstructor; eauto. - unfold loc_external_result. - apply agree_set_other; auto. apply agree_set_pair; auto. - -- (* return *) - inv STACKS. simpl in *. - right. split. omega. split. auto. - econstructor; eauto. rewrite ATPC; eauto. congruence. -Qed. - -Lemma transf_initial_states: - forall st1, Mach.initial_state prog st1 -> - exists st2, Asm.initial_state tprog st2 /\ match_states st1 st2. -Proof. - intros. inversion H. unfold ge0 in *. - econstructor; split. - econstructor. - eapply (Genv.init_mem_transf_partial TRANSF); eauto. - replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero) - with (Vptr fb Ptrofs.zero). - econstructor; eauto. - constructor. - apply Mem.extends_refl. - split. reflexivity. simpl. - unfold Vnullptr; destruct Archi.ptr64; congruence. - intros. rewrite Regmap.gi. auto. - unfold Genv.symbol_address. - rewrite (match_program_main TRANSF). - rewrite symbols_preserved. - unfold ge; rewrite H1. auto. -Qed. - -Lemma transf_final_states: - forall st1 st2 r, - match_states st1 st2 -> Mach.final_state st1 r -> Asm.final_state st2 r. -Proof. - intros. inv H0. inv H. constructor. auto. - assert (r0 = AX). - { unfold loc_result in H1; destruct Archi.ptr64; compute in H1; congruence. } - subst r0. - generalize (preg_val _ _ _ AX AG). rewrite H2. intros LD; inv LD. auto. -Qed. - -Theorem transf_program_correct: - forward_simulation (Mach.semantics return_address_offset prog) (Asm.semantics tprog). -Proof. - eapply forward_simulation_star with (measure := measure). - apply senv_preserved. - eexact transf_initial_states. - eexact transf_final_states. - exact step_simulation. -Qed. - -End PRESERVATION. diff --git a/ia32/Asmgenproof1.v b/ia32/Asmgenproof1.v deleted file mode 100644 index 05b3176a..00000000 --- a/ia32/Asmgenproof1.v +++ /dev/null @@ -1,1481 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Correctness proof for x86-64 generation: auxiliary results. *) - -Require Import Coqlib. -Require Import AST Errors Integers Floats Values Memory Globalenvs. -Require Import Op Locations Conventions Mach Asm. -Require Import Asmgen Asmgenproof0. - -Open Local Scope error_monad_scope. -Local Transparent Archi.ptr64. - -(** * Correspondence between Mach registers and x86 registers *) - -Lemma agree_nextinstr_nf: - forall ms sp rs, - agree ms sp rs -> agree ms sp (nextinstr_nf rs). -Proof. - intros. unfold nextinstr_nf. apply agree_nextinstr. - apply agree_undef_nondata_regs. auto. - simpl; intros. intuition (subst r; auto). -Qed. - -(** Useful properties of the PC register. *) - -Lemma nextinstr_nf_inv: - forall r rs, - match r with PC => False | CR _ => False | _ => True end -> - (nextinstr_nf rs)#r = rs#r. -Proof. - intros. unfold nextinstr_nf. rewrite nextinstr_inv. - simpl. repeat rewrite Pregmap.gso; auto; - red; intro; subst; contradiction. - red; intro; subst; contradiction. -Qed. - -Lemma nextinstr_nf_inv1: - forall r rs, - data_preg r = true -> (nextinstr_nf rs)#r = rs#r. -Proof. - intros. apply nextinstr_nf_inv. destruct r; auto || discriminate. -Qed. - -Lemma nextinstr_nf_set_preg: - forall rs m v, - (nextinstr_nf (rs#(preg_of m) <- v))#PC = Val.offset_ptr rs#PC Ptrofs.one. -Proof. - intros. unfold nextinstr_nf. - transitivity (nextinstr (rs#(preg_of m) <- v) PC). auto. - apply nextinstr_set_preg. -Qed. - -(** Useful simplification tactic *) - -Ltac Simplif := - match goal with - | [ |- nextinstr_nf _ _ = _ ] => - ((rewrite nextinstr_nf_inv by auto with asmgen) - || (rewrite nextinstr_nf_inv1 by auto with asmgen)); auto - | [ |- nextinstr _ _ = _ ] => - ((rewrite nextinstr_inv by auto with asmgen) - || (rewrite nextinstr_inv1 by auto with asmgen)); auto - | [ |- Pregmap.get ?x (Pregmap.set ?x _ _) = _ ] => - rewrite Pregmap.gss; auto - | [ |- Pregmap.set ?x _ _ ?x = _ ] => - rewrite Pregmap.gss; auto - | [ |- Pregmap.get _ (Pregmap.set _ _ _) = _ ] => - rewrite Pregmap.gso by (auto with asmgen); auto - | [ |- Pregmap.set _ _ _ _ = _ ] => - rewrite Pregmap.gso by (auto with asmgen); auto - end. - -Ltac Simplifs := repeat Simplif. - -(** * Correctness of x86-64 constructor functions *) - -Section CONSTRUCTORS. - -Variable ge: genv. -Variable fn: function. - -(** Smart constructor for moves. *) - -Lemma mk_mov_correct: - forall rd rs k c rs1 m, - mk_mov rd rs k = OK c -> - exists rs2, - exec_straight ge fn c rs1 m k rs2 m - /\ rs2#rd = rs1#rs - /\ forall r, data_preg r = true -> r <> rd -> rs2#r = rs1#r. -Proof. - unfold mk_mov; intros. - destruct rd; try (monadInv H); destruct rs; monadInv H. -(* mov *) - econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. Simplifs. intros; Simplifs. -(* movsd *) - econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. Simplifs. intros; Simplifs. -Qed. - -(** Properties of division *) - -Lemma divu_modu_exists: - forall v1 v2, - Val.divu v1 v2 <> None \/ Val.modu v1 v2 <> None -> - exists n d q r, - v1 = Vint n /\ v2 = Vint d - /\ Int.divmodu2 Int.zero n d = Some(q, r) - /\ Val.divu v1 v2 = Some (Vint q) /\ Val.modu v1 v2 = Some (Vint r). -Proof. - intros v1 v2; unfold Val.divu, Val.modu. - destruct v1; try (intuition discriminate). - destruct v2; try (intuition discriminate). - predSpec Int.eq Int.eq_spec i0 Int.zero ; try (intuition discriminate). - intros _. exists i, i0, (Int.divu i i0), (Int.modu i i0); intuition auto. - apply Int.divmodu2_divu_modu; auto. -Qed. - -Lemma divs_mods_exists: - forall v1 v2, - Val.divs v1 v2 <> None \/ Val.mods v1 v2 <> None -> - exists nh nl d q r, - Val.shr v1 (Vint (Int.repr 31)) = Vint nh /\ v1 = Vint nl /\ v2 = Vint d - /\ Int.divmods2 nh nl d = Some(q, r) - /\ Val.divs v1 v2 = Some (Vint q) /\ Val.mods v1 v2 = Some (Vint r). -Proof. - intros v1 v2; unfold Val.divs, Val.mods. - destruct v1; try (intuition discriminate). - destruct v2; try (intuition discriminate). - destruct (Int.eq i0 Int.zero - || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone) eqn:OK; - try (intuition discriminate). - intros _. - InvBooleans. - exists (Int.shr i (Int.repr 31)), i, i0, (Int.divs i i0), (Int.mods i i0); intuition auto. - rewrite Int.shr_lt_zero. apply Int.divmods2_divs_mods. - red; intros; subst i0; rewrite Int.eq_true in H; discriminate. - revert H0. predSpec Int.eq Int.eq_spec i (Int.repr Int.min_signed); auto. - predSpec Int.eq Int.eq_spec i0 Int.mone; auto. - discriminate. -Qed. - -Lemma divlu_modlu_exists: - forall v1 v2, - Val.divlu v1 v2 <> None \/ Val.modlu v1 v2 <> None -> - exists n d q r, - v1 = Vlong n /\ v2 = Vlong d - /\ Int64.divmodu2 Int64.zero n d = Some(q, r) - /\ Val.divlu v1 v2 = Some (Vlong q) /\ Val.modlu v1 v2 = Some (Vlong r). -Proof. - intros v1 v2; unfold Val.divlu, Val.modlu. - destruct v1; try (intuition discriminate). - destruct v2; try (intuition discriminate). - predSpec Int64.eq Int64.eq_spec i0 Int64.zero ; try (intuition discriminate). - intros _. exists i, i0, (Int64.divu i i0), (Int64.modu i i0); intuition auto. - apply Int64.divmodu2_divu_modu; auto. -Qed. - -Lemma divls_modls_exists: - forall v1 v2, - Val.divls v1 v2 <> None \/ Val.modls v1 v2 <> None -> - exists nh nl d q r, - Val.shrl v1 (Vint (Int.repr 63)) = Vlong nh /\ v1 = Vlong nl /\ v2 = Vlong d - /\ Int64.divmods2 nh nl d = Some(q, r) - /\ Val.divls v1 v2 = Some (Vlong q) /\ Val.modls v1 v2 = Some (Vlong r). -Proof. - intros v1 v2; unfold Val.divls, Val.modls. - destruct v1; try (intuition discriminate). - destruct v2; try (intuition discriminate). - destruct (Int64.eq i0 Int64.zero - || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone) eqn:OK; - try (intuition discriminate). - intros _. - InvBooleans. - exists (Int64.shr i (Int64.repr 63)), i, i0, (Int64.divs i i0), (Int64.mods i i0); intuition auto. - rewrite Int64.shr_lt_zero. apply Int64.divmods2_divs_mods. - red; intros; subst i0; rewrite Int64.eq_true in H; discriminate. - revert H0. predSpec Int64.eq Int64.eq_spec i (Int64.repr Int64.min_signed); auto. - predSpec Int64.eq Int64.eq_spec i0 Int64.mone; auto. - discriminate. -Qed. - -(** Smart constructor for [shrx] *) - -Lemma mk_shrximm_correct: - forall n k c (rs1: regset) v m, - mk_shrximm n k = OK c -> - Val.shrx (rs1#RAX) (Vint n) = Some v -> - exists rs2, - exec_straight ge fn c rs1 m k rs2 m - /\ rs2#RAX = v - /\ forall r, data_preg r = true -> r <> RAX -> r <> RCX -> rs2#r = rs1#r. -Proof. - unfold mk_shrximm; intros. inv H. - exploit Val.shrx_shr; eauto. intros [x [y [A [B C]]]]. - inversion B; clear B; subst y; subst v; clear H0. - set (tnm1 := Int.sub (Int.shl Int.one n) Int.one). - set (x' := Int.add x tnm1). - set (rs2 := nextinstr (compare_ints (Vint x) (Vint Int.zero) rs1 m)). - set (rs3 := nextinstr (rs2#RCX <- (Vint x'))). - set (rs4 := nextinstr (if Int.lt x Int.zero then rs3#RAX <- (Vint x') else rs3)). - set (rs5 := nextinstr_nf (rs4#RAX <- (Val.shr rs4#RAX (Vint n)))). - assert (rs3#RAX = Vint x). unfold rs3. Simplifs. - assert (rs3#RCX = Vint x'). unfold rs3. Simplifs. - exists rs5. split. - apply exec_straight_step with rs2 m. simpl. rewrite A. simpl. rewrite Int.and_idem. auto. auto. - apply exec_straight_step with rs3 m. simpl. - change (rs2 RAX) with (rs1 RAX). rewrite A. simpl. - rewrite Int.repr_unsigned. rewrite Int.add_zero_l. auto. auto. - apply exec_straight_step with rs4 m. simpl. - rewrite Int.lt_sub_overflow. unfold rs4. destruct (Int.lt x Int.zero); simpl; auto. - unfold rs4. destruct (Int.lt x Int.zero); simpl; auto. - apply exec_straight_one. auto. auto. - split. unfold rs5. Simplifs. unfold rs4. rewrite nextinstr_inv; auto with asmgen. - destruct (Int.lt x Int.zero). rewrite Pregmap.gss. rewrite A; auto. rewrite A; rewrite H; auto. - intros. unfold rs5. Simplifs. unfold rs4. Simplifs. - transitivity (rs3#r). destruct (Int.lt x Int.zero). Simplifs. auto. - unfold rs3. Simplifs. unfold rs2. Simplifs. - unfold compare_ints. Simplifs. -Qed. - -(** Smart constructor for [shrxl] *) - -Lemma mk_shrxlimm_correct: - forall n k c (rs1: regset) v m, - mk_shrxlimm n k = OK c -> - Val.shrxl (rs1#RAX) (Vint n) = Some v -> - exists rs2, - exec_straight ge fn c rs1 m k rs2 m - /\ rs2#RAX = v - /\ forall r, data_preg r = true -> r <> RAX -> r <> RDX -> rs2#r = rs1#r. -Proof. - unfold mk_shrxlimm; intros. exploit Val.shrxl_shrl_2; eauto. intros EQ. - destruct (Int.eq n Int.zero); inv H. -- econstructor; split. apply exec_straight_one. simpl; reflexivity. auto. - split. Simplifs. intros; Simplifs. -- set (v1 := Val.shrl (rs1 RAX) (Vint (Int.repr 63))) in *. - set (v2 := Val.shrlu v1 (Vint (Int.sub (Int.repr 64) n))) in *. - set (v3 := Val.addl (rs1 RAX) v2) in *. - set (v4 := Val.shrl v3 (Vint n)) in *. - set (rs2 := nextinstr_nf (rs1#RDX <- v1)). - set (rs3 := nextinstr_nf (rs2#RDX <- v2)). - set (rs4 := nextinstr (rs3#RAX <- v3)). - set (rs5 := nextinstr_nf (rs4#RAX <- v4)). - assert (X: forall v1 v2, - Val.addl v1 (Val.addl v2 (Vlong Int64.zero)) = Val.addl v1 v2). - { intros. destruct v0; simpl; auto; destruct v5; simpl; auto. - rewrite Int64.add_zero; auto. - destruct Archi.ptr64; auto. rewrite Ptrofs.add_zero; auto. - destruct Archi.ptr64; auto. rewrite Int64.add_zero; auto. - destruct Archi.ptr64; 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. - 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); simpl in H0; inv H0; - 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. -- destruct Archi.ptr64 eqn:SF; inv H2. rewrite ! A by auto. auto. -- destruct Archi.ptr64 eqn:SF; inv H2. erewrite ireg_of_eq by eauto. - rewrite Val.add_commut. rewrite A by auto. auto. -- destruct Archi.ptr64 eqn:SF; inv H2. erewrite ireg_of_eq by eauto. - rewrite Val.add_permut. rewrite Val.add_commut. apply Val.add_lessdef; auto. rewrite A; auto. -- destruct Archi.ptr64 eqn:SF; inv H2. simpl. - destruct (rs RSP); simpl; auto; rewrite SF. - 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); simpl in H0; inv H0; - 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. -- destruct Archi.ptr64 eqn:SF; inv H2. rewrite ! A by auto. auto. -- destruct Archi.ptr64 eqn:SF; inv H2. simpl. - destruct (rs RSP); simpl; auto; rewrite SF. - rewrite Int64.add_zero_l. apply Val.lessdef_same; f_equal; f_equal. - symmetry. transitivity (Ptrofs.repr (Ptrofs.signed i)). auto with ptrofs. auto with ints. -Qed. - -Lemma transl_addressing_mode_correct: - forall addr args am (rs: regset) v, - transl_addressing addr args = OK am -> - eval_addressing ge (rs RSP) addr (List.map rs (List.map preg_of args)) = Some v -> - Val.lessdef v (eval_addrmode ge am rs). -Proof. - unfold eval_addressing, eval_addrmode; intros. destruct Archi.ptr64. - eapply transl_addressing_mode_64_correct; eauto. - eapply transl_addressing_mode_32_correct; eauto. -Qed. - -Lemma normalize_addrmode_32_correct: - forall am rs, eval_addrmode32 ge (normalize_addrmode_32 am) rs = eval_addrmode32 ge am rs. -Proof. - intros; destruct am as [base ofs [n|r]]; simpl; auto. rewrite Int.repr_signed. auto. -Qed. - -Lemma normalize_addrmode_64_correct: - forall am rs, - eval_addrmode64 ge am rs = - match normalize_addrmode_64 am with - | (am', None) => eval_addrmode64 ge am' rs - | (am', Some delta) => Val.addl (eval_addrmode64 ge am' rs) (Vlong delta) - end. -Proof. - intros; destruct am as [base ofs [n|r]]; simpl; auto. - destruct (zeq (Int.signed (Int.repr n)) n); simpl; auto. - rewrite ! Val.addl_assoc. apply f_equal. apply f_equal. simpl. rewrite Int64.add_zero_l; auto. -Qed. - -(** Processor conditions and comparisons *) - -Lemma compare_ints_spec: - forall rs v1 v2 m, - let rs' := nextinstr (compare_ints v1 v2 rs m) in - rs'#ZF = Val.cmpu (Mem.valid_pointer m) Ceq v1 v2 - /\ rs'#CF = Val.cmpu (Mem.valid_pointer m) Clt v1 v2 - /\ rs'#SF = Val.negative (Val.sub v1 v2) - /\ rs'#OF = Val.sub_overflow v1 v2 - /\ (forall r, data_preg r = true -> rs'#r = rs#r). -Proof. - intros. unfold rs'; unfold compare_ints. - split. auto. - split. auto. - split. auto. - split. auto. - intros. Simplifs. -Qed. - -Lemma testcond_for_signed_comparison_32_correct: - forall c v1 v2 rs m b, - Val.cmp_bool c v1 v2 = Some b -> - eval_testcond (testcond_for_signed_comparison c) - (nextinstr (compare_ints v1 v2 rs m)) = Some b. -Proof. - intros. generalize (compare_ints_spec rs v1 v2 m). - set (rs' := nextinstr (compare_ints v1 v2 rs m)). - intros [A [B [C [D E]]]]. - destruct v1; destruct v2; simpl in H; inv H. - unfold eval_testcond. rewrite A; rewrite B; rewrite C; rewrite D. - simpl. unfold Val.cmp, Val.cmpu. - rewrite Int.lt_sub_overflow. - destruct c; simpl. - destruct (Int.eq i i0); auto. - destruct (Int.eq i i0); auto. - destruct (Int.lt i i0); auto. - rewrite Int.not_lt. destruct (Int.lt i i0); simpl; destruct (Int.eq i i0); auto. - rewrite (Int.lt_not i i0). destruct (Int.lt i i0); destruct (Int.eq i i0); reflexivity. - destruct (Int.lt i i0); reflexivity. -Qed. - -Lemma testcond_for_unsigned_comparison_32_correct: - forall c v1 v2 rs m b, - Val.cmpu_bool (Mem.valid_pointer m) c v1 v2 = Some b -> - eval_testcond (testcond_for_unsigned_comparison c) - (nextinstr (compare_ints v1 v2 rs m)) = Some b. -Proof. - intros. generalize (compare_ints_spec rs v1 v2 m). - set (rs' := nextinstr (compare_ints v1 v2 rs m)). - intros [A [B [C [D E]]]]. - unfold eval_testcond. rewrite A; rewrite B. unfold Val.cmpu, Val.cmp. - destruct v1; destruct v2; simpl in H; inv H. -- (* 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; destruct Archi.ptr64; try discriminate. - 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. - destruct c; simpl in *; inv H1; reflexivity. -- (* ptr int *) - unfold Val.cmpu_bool; destruct Archi.ptr64; try discriminate. - 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. - destruct c; simpl in *; inv H1; reflexivity. -- (* ptr ptr *) - unfold Val.cmpu_bool; destruct Archi.ptr64; try discriminate. - 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 H1. - 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. - destruct c; simpl in *; inv H1; 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; inv H. -- (* 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. - destruct c; simpl in *; inv H1; 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. - destruct c; simpl in *; inv H1; auto. -- (* ptr ptr *) - unfold Val.cmplu; simpl; destruct Archi.ptr64; try discriminate. - 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 H1. - 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. - destruct c; simpl in *; inv H1; reflexivity. -Qed. - -Lemma compare_floats_spec: - forall rs n1 n2, - let rs' := nextinstr (compare_floats (Vfloat n1) (Vfloat n2) rs) in - rs'#ZF = Val.of_bool (negb (Float.cmp Cne n1 n2)) - /\ rs'#CF = Val.of_bool (negb (Float.cmp Cge n1 n2)) - /\ rs'#PF = Val.of_bool (negb (Float.cmp Ceq n1 n2 || Float.cmp Clt n1 n2 || Float.cmp Cgt n1 n2)) - /\ (forall r, data_preg r = true -> rs'#r = rs#r). -Proof. - intros. unfold rs'; unfold compare_floats. - split. auto. - split. auto. - split. auto. - intros. Simplifs. -Qed. - -Lemma compare_floats32_spec: - forall rs n1 n2, - let rs' := nextinstr (compare_floats32 (Vsingle n1) (Vsingle n2) rs) in - rs'#ZF = Val.of_bool (negb (Float32.cmp Cne n1 n2)) - /\ rs'#CF = Val.of_bool (negb (Float32.cmp Cge n1 n2)) - /\ rs'#PF = Val.of_bool (negb (Float32.cmp Ceq n1 n2 || Float32.cmp Clt n1 n2 || Float32.cmp Cgt n1 n2)) - /\ (forall r, data_preg r = true -> rs'#r = rs#r). -Proof. - intros. unfold rs'; unfold compare_floats32. - split. auto. - split. auto. - split. auto. - intros. Simplifs. -Qed. - -Definition eval_extcond (xc: extcond) (rs: regset) : option bool := - match xc with - | Cond_base c => - eval_testcond c rs - | Cond_and c1 c2 => - match eval_testcond c1 rs, eval_testcond c2 rs with - | Some b1, Some b2 => Some (b1 && b2) - | _, _ => None - end - | Cond_or c1 c2 => - match eval_testcond c1 rs, eval_testcond c2 rs with - | Some b1, Some b2 => Some (b1 || b2) - | _, _ => None - end - end. - -Definition swap_floats {A: Type} (c: comparison) (n1 n2: A) : A := - match c with - | Clt | Cle => n2 - | Ceq | Cne | Cgt | Cge => n1 - end. - -Lemma testcond_for_float_comparison_correct: - forall c n1 n2 rs, - eval_extcond (testcond_for_condition (Ccompf c)) - (nextinstr (compare_floats (Vfloat (swap_floats c n1 n2)) - (Vfloat (swap_floats c n2 n1)) rs)) = - Some(Float.cmp c n1 n2). -Proof. - intros. - generalize (compare_floats_spec rs (swap_floats c n1 n2) (swap_floats c n2 n1)). - set (rs' := nextinstr (compare_floats (Vfloat (swap_floats c n1 n2)) - (Vfloat (swap_floats c n2 n1)) rs)). - intros [A [B [C D]]]. - unfold eval_extcond, eval_testcond. rewrite A; rewrite B; rewrite C. - destruct c; simpl. -(* eq *) - rewrite Float.cmp_ne_eq. - caseEq (Float.cmp Ceq n1 n2); intros. - auto. - simpl. destruct (Float.cmp Clt n1 n2 || Float.cmp Cgt n1 n2); auto. -(* ne *) - rewrite Float.cmp_ne_eq. - caseEq (Float.cmp Ceq n1 n2); intros. - auto. - simpl. destruct (Float.cmp Clt n1 n2 || Float.cmp Cgt n1 n2); auto. -(* lt *) - rewrite <- (Float.cmp_swap Cge n1 n2). - rewrite <- (Float.cmp_swap Cne n1 n2). - simpl. - rewrite Float.cmp_ne_eq. rewrite Float.cmp_le_lt_eq. - caseEq (Float.cmp Clt n1 n2); intros; simpl. - caseEq (Float.cmp Ceq n1 n2); intros; simpl. - elimtype False. eapply Float.cmp_lt_eq_false; eauto. - auto. - destruct (Float.cmp Ceq n1 n2); auto. -(* le *) - rewrite <- (Float.cmp_swap Cge n1 n2). simpl. - destruct (Float.cmp Cle n1 n2); auto. -(* gt *) - rewrite Float.cmp_ne_eq. rewrite Float.cmp_ge_gt_eq. - caseEq (Float.cmp Cgt n1 n2); intros; simpl. - caseEq (Float.cmp Ceq n1 n2); intros; simpl. - elimtype False. eapply Float.cmp_gt_eq_false; eauto. - auto. - destruct (Float.cmp Ceq n1 n2); auto. -(* ge *) - destruct (Float.cmp Cge n1 n2); auto. -Qed. - -Lemma testcond_for_neg_float_comparison_correct: - forall c n1 n2 rs, - eval_extcond (testcond_for_condition (Cnotcompf c)) - (nextinstr (compare_floats (Vfloat (swap_floats c n1 n2)) - (Vfloat (swap_floats c n2 n1)) rs)) = - Some(negb(Float.cmp c n1 n2)). -Proof. - intros. - generalize (compare_floats_spec rs (swap_floats c n1 n2) (swap_floats c n2 n1)). - set (rs' := nextinstr (compare_floats (Vfloat (swap_floats c n1 n2)) - (Vfloat (swap_floats c n2 n1)) rs)). - intros [A [B [C D]]]. - unfold eval_extcond, eval_testcond. rewrite A; rewrite B; rewrite C. - destruct c; simpl. -(* eq *) - rewrite Float.cmp_ne_eq. - caseEq (Float.cmp Ceq n1 n2); intros. - auto. - simpl. destruct (Float.cmp Clt n1 n2 || Float.cmp Cgt n1 n2); auto. -(* ne *) - rewrite Float.cmp_ne_eq. - caseEq (Float.cmp Ceq n1 n2); intros. - auto. - simpl. destruct (Float.cmp Clt n1 n2 || Float.cmp Cgt n1 n2); auto. -(* lt *) - rewrite <- (Float.cmp_swap Cge n1 n2). - rewrite <- (Float.cmp_swap Cne n1 n2). - simpl. - rewrite Float.cmp_ne_eq. rewrite Float.cmp_le_lt_eq. - caseEq (Float.cmp Clt n1 n2); intros; simpl. - caseEq (Float.cmp Ceq n1 n2); intros; simpl. - elimtype False. eapply Float.cmp_lt_eq_false; eauto. - auto. - destruct (Float.cmp Ceq n1 n2); auto. -(* le *) - rewrite <- (Float.cmp_swap Cge n1 n2). simpl. - destruct (Float.cmp Cle n1 n2); auto. -(* gt *) - rewrite Float.cmp_ne_eq. rewrite Float.cmp_ge_gt_eq. - caseEq (Float.cmp Cgt n1 n2); intros; simpl. - caseEq (Float.cmp Ceq n1 n2); intros; simpl. - elimtype False. eapply Float.cmp_gt_eq_false; eauto. - auto. - destruct (Float.cmp Ceq n1 n2); auto. -(* ge *) - destruct (Float.cmp Cge n1 n2); auto. -Qed. - -Lemma testcond_for_float32_comparison_correct: - forall c n1 n2 rs, - eval_extcond (testcond_for_condition (Ccompfs c)) - (nextinstr (compare_floats32 (Vsingle (swap_floats c n1 n2)) - (Vsingle (swap_floats c n2 n1)) rs)) = - Some(Float32.cmp c n1 n2). -Proof. - intros. - generalize (compare_floats32_spec rs (swap_floats c n1 n2) (swap_floats c n2 n1)). - set (rs' := nextinstr (compare_floats32 (Vsingle (swap_floats c n1 n2)) - (Vsingle (swap_floats c n2 n1)) rs)). - intros [A [B [C D]]]. - unfold eval_extcond, eval_testcond. rewrite A; rewrite B; rewrite C. - destruct c; simpl. -(* eq *) - rewrite Float32.cmp_ne_eq. - caseEq (Float32.cmp Ceq n1 n2); intros. - auto. - simpl. destruct (Float32.cmp Clt n1 n2 || Float32.cmp Cgt n1 n2); auto. -(* ne *) - rewrite Float32.cmp_ne_eq. - caseEq (Float32.cmp Ceq n1 n2); intros. - auto. - simpl. destruct (Float32.cmp Clt n1 n2 || Float32.cmp Cgt n1 n2); auto. -(* lt *) - rewrite <- (Float32.cmp_swap Cge n1 n2). - rewrite <- (Float32.cmp_swap Cne n1 n2). - simpl. - rewrite Float32.cmp_ne_eq. rewrite Float32.cmp_le_lt_eq. - caseEq (Float32.cmp Clt n1 n2); intros; simpl. - caseEq (Float32.cmp Ceq n1 n2); intros; simpl. - elimtype False. eapply Float32.cmp_lt_eq_false; eauto. - auto. - destruct (Float32.cmp Ceq n1 n2); auto. -(* le *) - rewrite <- (Float32.cmp_swap Cge n1 n2). simpl. - destruct (Float32.cmp Cle n1 n2); auto. -(* gt *) - rewrite Float32.cmp_ne_eq. rewrite Float32.cmp_ge_gt_eq. - caseEq (Float32.cmp Cgt n1 n2); intros; simpl. - caseEq (Float32.cmp Ceq n1 n2); intros; simpl. - elimtype False. eapply Float32.cmp_gt_eq_false; eauto. - auto. - destruct (Float32.cmp Ceq n1 n2); auto. -(* ge *) - destruct (Float32.cmp Cge n1 n2); auto. -Qed. - -Lemma testcond_for_neg_float32_comparison_correct: - forall c n1 n2 rs, - eval_extcond (testcond_for_condition (Cnotcompfs c)) - (nextinstr (compare_floats32 (Vsingle (swap_floats c n1 n2)) - (Vsingle (swap_floats c n2 n1)) rs)) = - Some(negb(Float32.cmp c n1 n2)). -Proof. - intros. - generalize (compare_floats32_spec rs (swap_floats c n1 n2) (swap_floats c n2 n1)). - set (rs' := nextinstr (compare_floats32 (Vsingle (swap_floats c n1 n2)) - (Vsingle (swap_floats c n2 n1)) rs)). - intros [A [B [C D]]]. - unfold eval_extcond, eval_testcond. rewrite A; rewrite B; rewrite C. - destruct c; simpl. -(* eq *) - rewrite Float32.cmp_ne_eq. - caseEq (Float32.cmp Ceq n1 n2); intros. - auto. - simpl. destruct (Float32.cmp Clt n1 n2 || Float32.cmp Cgt n1 n2); auto. -(* ne *) - rewrite Float32.cmp_ne_eq. - caseEq (Float32.cmp Ceq n1 n2); intros. - auto. - simpl. destruct (Float32.cmp Clt n1 n2 || Float32.cmp Cgt n1 n2); auto. -(* lt *) - rewrite <- (Float32.cmp_swap Cge n1 n2). - rewrite <- (Float32.cmp_swap Cne n1 n2). - simpl. - rewrite Float32.cmp_ne_eq. rewrite Float32.cmp_le_lt_eq. - caseEq (Float32.cmp Clt n1 n2); intros; simpl. - caseEq (Float32.cmp Ceq n1 n2); intros; simpl. - elimtype False. eapply Float32.cmp_lt_eq_false; eauto. - auto. - destruct (Float32.cmp Ceq n1 n2); auto. -(* le *) - rewrite <- (Float32.cmp_swap Cge n1 n2). simpl. - destruct (Float32.cmp Cle n1 n2); auto. -(* gt *) - rewrite Float32.cmp_ne_eq. rewrite Float32.cmp_ge_gt_eq. - caseEq (Float32.cmp Cgt n1 n2); intros; simpl. - caseEq (Float32.cmp Ceq n1 n2); intros; simpl. - elimtype False. eapply Float32.cmp_gt_eq_false; eauto. - auto. - destruct (Float32.cmp Ceq n1 n2); auto. -(* ge *) - destruct (Float32.cmp Cge n1 n2); auto. -Qed. - -Remark swap_floats_commut: - forall (A B: Type) c (f: A -> B) x y, swap_floats c (f x) (f y) = f (swap_floats c x y). -Proof. - intros. destruct c; auto. -Qed. - -Remark compare_floats_inv: - forall vx vy rs r, - r <> CR ZF -> r <> CR CF -> r <> CR PF -> r <> CR SF -> r <> CR OF -> - compare_floats vx vy rs r = rs r. -Proof. - intros. - assert (DFL: undef_regs (CR ZF :: CR CF :: CR PF :: CR SF :: CR OF :: nil) rs r = rs r). - simpl. Simplifs. - unfold compare_floats; destruct vx; destruct vy; auto. Simplifs. -Qed. - -Remark compare_floats32_inv: - forall vx vy rs r, - r <> CR ZF -> r <> CR CF -> r <> CR PF -> r <> CR SF -> r <> CR OF -> - compare_floats32 vx vy rs r = rs r. -Proof. - intros. - assert (DFL: undef_regs (CR ZF :: CR CF :: CR PF :: CR SF :: CR OF :: nil) rs r = rs r). - simpl. Simplifs. - unfold compare_floats32; destruct vx; destruct vy; auto. Simplifs. -Qed. - -Lemma transl_cond_correct: - forall cond args k c rs m, - transl_cond cond args k = OK c -> - exists rs', - exec_straight ge fn c rs m k rs' m - /\ match eval_condition cond (map rs (map preg_of args)) m with - | None => True - | Some b => eval_extcond (testcond_for_condition cond) rs' = Some b - end - /\ forall r, data_preg r = true -> rs'#r = rs r. -Proof. - unfold transl_cond; intros. - destruct cond; repeat (destruct args; try discriminate); monadInv H. -- (* comp *) - simpl. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1). - econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. destruct (Val.cmp_bool c0 (rs x) (rs x0)) eqn:?; auto. - eapply testcond_for_signed_comparison_32_correct; eauto. - intros. unfold compare_ints. Simplifs. -- (* compu *) - simpl. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1). - econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. destruct (Val.cmpu_bool (Mem.valid_pointer m) c0 (rs x) (rs x0)) eqn:?; auto. - eapply testcond_for_unsigned_comparison_32_correct; eauto. - intros. unfold compare_ints. Simplifs. -- (* compimm *) - simpl. rewrite (ireg_of_eq _ _ EQ). destruct (Int.eq_dec n Int.zero). - econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split. destruct (rs x); simpl; auto. subst. rewrite Int.and_idem. - eapply testcond_for_signed_comparison_32_correct; eauto. - intros. unfold compare_ints. Simplifs. - econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split. destruct (Val.cmp_bool c0 (rs x) (Vint n)) eqn:?; auto. - eapply testcond_for_signed_comparison_32_correct; eauto. - intros. unfold compare_ints. Simplifs. -- (* compuimm *) - simpl. rewrite (ireg_of_eq _ _ EQ). - econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. destruct (Val.cmpu_bool (Mem.valid_pointer m) c0 (rs x) (Vint n)) eqn:?; auto. - eapply testcond_for_unsigned_comparison_32_correct; eauto. - intros. unfold compare_ints. Simplifs. -- (* compl *) - simpl. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1). - econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. destruct (Val.cmpl_bool c0 (rs x) (rs x0)) eqn:?; auto. - eapply testcond_for_signed_comparison_64_correct; eauto. - intros. unfold compare_longs. Simplifs. -- (* complu *) - simpl. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1). - econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. destruct (Val.cmplu_bool (Mem.valid_pointer m) c0 (rs x) (rs x0)) eqn:?; auto. - eapply testcond_for_unsigned_comparison_64_correct; eauto. - intros. unfold compare_longs. Simplifs. -- (* compimm *) - simpl. rewrite (ireg_of_eq _ _ EQ). destruct (Int64.eq_dec n Int64.zero). - econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split. destruct (rs x); simpl; auto. subst. rewrite Int64.and_idem. - eapply testcond_for_signed_comparison_64_correct; eauto. - intros. unfold compare_longs. Simplifs. - econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split. destruct (Val.cmpl_bool c0 (rs x) (Vlong n)) eqn:?; auto. - eapply testcond_for_signed_comparison_64_correct; eauto. - intros. unfold compare_longs. Simplifs. -- (* compuimm *) - simpl. rewrite (ireg_of_eq _ _ EQ). - econstructor. split. apply exec_straight_one. simpl. eauto. auto. - split. destruct (Val.cmplu_bool (Mem.valid_pointer m) c0 (rs x) (Vlong n)) eqn:?; auto. - eapply testcond_for_unsigned_comparison_64_correct; eauto. - intros. unfold compare_longs. Simplifs. -- (* compf *) - simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1). - exists (nextinstr (compare_floats (swap_floats c0 (rs x) (rs x0)) (swap_floats c0 (rs x0) (rs x)) rs)). - split. apply exec_straight_one. - destruct c0; simpl; auto. - unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats_inv; auto with asmgen. - split. destruct (rs x); destruct (rs x0); simpl; auto. - repeat rewrite swap_floats_commut. apply testcond_for_float_comparison_correct. - intros. Simplifs. apply compare_floats_inv; auto with asmgen. -- (* notcompf *) - simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1). - exists (nextinstr (compare_floats (swap_floats c0 (rs x) (rs x0)) (swap_floats c0 (rs x0) (rs x)) rs)). - split. apply exec_straight_one. - destruct c0; simpl; auto. - unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats_inv; auto with asmgen. - split. destruct (rs x); destruct (rs x0); simpl; auto. - repeat rewrite swap_floats_commut. apply testcond_for_neg_float_comparison_correct. - intros. Simplifs. apply compare_floats_inv; auto with asmgen. -- (* compfs *) - simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1). - exists (nextinstr (compare_floats32 (swap_floats c0 (rs x) (rs x0)) (swap_floats c0 (rs x0) (rs x)) rs)). - split. apply exec_straight_one. - destruct c0; simpl; auto. - unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats32_inv; auto with asmgen. - split. destruct (rs x); destruct (rs x0); simpl; auto. - repeat rewrite swap_floats_commut. apply testcond_for_float32_comparison_correct. - intros. Simplifs. apply compare_floats32_inv; auto with asmgen. -- (* notcompfs *) - simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1). - exists (nextinstr (compare_floats32 (swap_floats c0 (rs x) (rs x0)) (swap_floats c0 (rs x0) (rs x)) rs)). - split. apply exec_straight_one. - destruct c0; simpl; auto. - unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats32_inv; auto with asmgen. - split. destruct (rs x); destruct (rs x0); simpl; auto. - repeat rewrite swap_floats_commut. apply testcond_for_neg_float32_comparison_correct. - intros. Simplifs. apply compare_floats32_inv; auto with asmgen. -- (* maskzero *) - simpl. rewrite (ireg_of_eq _ _ EQ). - econstructor. split. apply exec_straight_one. simpl; eauto. auto. - split. destruct (rs x); simpl; auto. - generalize (compare_ints_spec rs (Vint (Int.and i n)) Vzero m). - intros [A B]. rewrite A. unfold Val.cmpu; simpl. destruct (Int.eq (Int.and i n) Int.zero); auto. - intros. unfold compare_ints. Simplifs. -- (* masknotzero *) - simpl. rewrite (ireg_of_eq _ _ EQ). - econstructor. split. apply exec_straight_one. simpl; eauto. auto. - split. destruct (rs x); simpl; auto. - generalize (compare_ints_spec rs (Vint (Int.and i n)) Vzero m). - intros [A B]. rewrite A. unfold Val.cmpu; simpl. destruct (Int.eq (Int.and i n) Int.zero); auto. - intros. unfold compare_ints. Simplifs. -Qed. - -Remark eval_testcond_nextinstr: - forall c rs, eval_testcond c (nextinstr rs) = eval_testcond c rs. -Proof. - intros. unfold eval_testcond. repeat rewrite nextinstr_inv; auto with asmgen. -Qed. - -Remark eval_testcond_set_ireg: - forall c rs r v, eval_testcond c (rs#(IR r) <- v) = eval_testcond c rs. -Proof. - intros. unfold eval_testcond. repeat rewrite Pregmap.gso; auto with asmgen. -Qed. - -Lemma mk_setcc_base_correct: - forall cond rd k rs1 m, - exists rs2, - exec_straight ge fn (mk_setcc_base cond rd k) rs1 m k rs2 m - /\ rs2#rd = Val.of_optbool(eval_extcond cond rs1) - /\ forall r, data_preg r = true -> r <> RAX /\ r <> RCX -> r <> rd -> rs2#r = rs1#r. -Proof. - intros. destruct cond; simpl in *. -- (* base *) - econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split. Simplifs. intros; Simplifs. -- (* or *) - assert (Val.of_optbool - match eval_testcond c1 rs1 with - | Some b1 => - match eval_testcond c2 rs1 with - | Some b2 => Some (b1 || b2) - | None => None - end - | None => None - end = - Val.or (Val.of_optbool (eval_testcond c1 rs1)) (Val.of_optbool (eval_testcond c2 rs1))). - destruct (eval_testcond c1 rs1). destruct (eval_testcond c2 rs1). - destruct b; destruct b0; auto. - destruct b; auto. - auto. - rewrite H; clear H. - destruct (ireg_eq rd RAX). - subst rd. econstructor; split. - eapply exec_straight_three. - simpl; eauto. - simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. eauto. - simpl; eauto. - auto. auto. auto. - intuition Simplifs. - econstructor; split. - eapply exec_straight_three. - simpl; eauto. - simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. eauto. - simpl. eauto. - auto. auto. auto. - split. Simplifs. rewrite Val.or_commut. decEq; Simplifs. - intros. destruct H0; Simplifs. -- (* and *) - assert (Val.of_optbool - match eval_testcond c1 rs1 with - | Some b1 => - match eval_testcond c2 rs1 with - | Some b2 => Some (b1 && b2) - | None => None - end - | None => None - end = - Val.and (Val.of_optbool (eval_testcond c1 rs1)) (Val.of_optbool (eval_testcond c2 rs1))). - { - destruct (eval_testcond c1 rs1). destruct (eval_testcond c2 rs1). - destruct b; destruct b0; auto. - destruct b; auto. - auto. - } - rewrite H; clear H. - destruct (ireg_eq rd RAX). - subst rd. econstructor; split. - eapply exec_straight_three. - simpl; eauto. - simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. eauto. - simpl; eauto. - auto. auto. auto. - intuition Simplifs. - econstructor; split. - eapply exec_straight_three. - simpl; eauto. - simpl. rewrite eval_testcond_nextinstr. repeat rewrite eval_testcond_set_ireg. eauto. - simpl. eauto. - auto. auto. auto. - split. Simplifs. rewrite Val.and_commut. decEq; Simplifs. - intros. destruct H0; Simplifs. -Qed. - -Lemma mk_setcc_correct: - forall cond rd k rs1 m, - exists rs2, - exec_straight ge fn (mk_setcc cond rd k) rs1 m k rs2 m - /\ rs2#rd = Val.of_optbool(eval_extcond cond rs1) - /\ forall r, data_preg r = true -> r <> RAX /\ r <> RCX -> r <> rd -> rs2#r = rs1#r. -Proof. - intros. unfold mk_setcc. destruct (Archi.ptr64 || low_ireg rd). -- apply mk_setcc_base_correct. -- exploit mk_setcc_base_correct. intros [rs2 [A [B C]]]. - econstructor; split. eapply exec_straight_trans. eexact A. apply exec_straight_one. - simpl. eauto. simpl. auto. - intuition Simplifs. -Qed. - -(** Translation of arithmetic operations. *) - -Ltac ArgsInv := - match goal with - | [ H: Error _ = OK _ |- _ ] => discriminate - | [ H: match ?args with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct args; ArgsInv - | [ H: bind _ _ = OK _ |- _ ] => monadInv H; ArgsInv - | [ H: match _ with left _ => _ | right _ => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv - | [ H: match _ with true => _ | false => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv - | [ H: ireg_of _ = OK _ |- _ ] => simpl in *; rewrite (ireg_of_eq _ _ H) in *; clear H; ArgsInv - | [ H: freg_of _ = OK _ |- _ ] => simpl in *; rewrite (freg_of_eq _ _ H) in *; clear H; ArgsInv - | _ => idtac - end. - -Ltac TranslOp := - econstructor; split; - [ apply exec_straight_one; [ simpl; eauto | auto ] - | split; [ Simplifs | intros; Simplifs ]]. - -Lemma transl_op_correct: - forall op args res k c (rs: regset) m v, - transl_op op args res k = OK c -> - eval_operation ge (rs#RSP) op (map rs (map preg_of args)) m = Some v -> - exists rs', - exec_straight ge fn c rs m k rs' m - /\ Val.lessdef v rs'#(preg_of res) - /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r. -Proof. -Transparent destroyed_by_op. - intros until v; intros TR EV. - assert (SAME: - (exists rs', - exec_straight ge fn c rs m k rs' m - /\ rs'#(preg_of res) = v - /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r) -> - exists rs', - exec_straight ge fn c rs m k rs' m - /\ Val.lessdef v rs'#(preg_of res) - /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r). - { - intros [rs' [A [B C]]]. subst v. exists rs'; auto. - } - - destruct op; simpl in TR; ArgsInv; simpl in EV; try (inv EV); try (apply SAME; TranslOp; fail). -(* move *) - exploit mk_mov_correct; eauto. intros [rs2 [A [B C]]]. - apply SAME. exists rs2. eauto. -(* intconst *) - apply SAME. destruct (Int.eq_dec n Int.zero). subst n. TranslOp. TranslOp. -(* longconst *) - apply SAME. destruct (Int64.eq_dec n Int64.zero). subst n. TranslOp. TranslOp. -(* floatconst *) - apply SAME. destruct (Float.eq_dec n Float.zero). subst n. TranslOp. TranslOp. -(* singleconst *) - apply SAME. destruct (Float32.eq_dec n Float32.zero). subst n. TranslOp. TranslOp. -(* cast8signed *) - apply SAME. eapply mk_intconv_correct; eauto. -(* cast8unsigned *) - apply SAME. eapply mk_intconv_correct; eauto. -(* mulhs *) - apply SAME. TranslOp. destruct H1. Simplifs. -(* mulhu *) - apply SAME. TranslOp. destruct H1. Simplifs. -(* div *) - apply SAME. - exploit (divs_mods_exists (rs RAX) (rs RCX)). left; congruence. - intros (nh & nl & d & q & r & A & B & C & D & E & F). - set (rs1 := nextinstr_nf (rs#RDX <- (Vint nh))). - econstructor; split. - eapply exec_straight_two with (rs2 := rs1). simpl. rewrite A. reflexivity. - simpl. change (rs1 RAX) with (rs RAX); rewrite B. - change (rs1 RCX) with (rs RCX); rewrite C. - rewrite D. reflexivity. auto. auto. - split. change (Vint q = v). congruence. - simpl; intros. destruct H2. unfold rs1; Simplifs. -(* divu *) - apply SAME. - exploit (divu_modu_exists (rs RAX) (rs RCX)). left; congruence. - intros (n & d & q & r & B & C & D & E & F). - set (rs1 := nextinstr_nf (rs#RDX <- Vzero)). - econstructor; split. - eapply exec_straight_two with (rs2 := rs1). reflexivity. - simpl. change (rs1 RAX) with (rs RAX); rewrite B. - change (rs1 RCX) with (rs RCX); rewrite C. - rewrite D. reflexivity. auto. auto. - split. change (Vint q = v). congruence. - simpl; intros. destruct H2. unfold rs1; Simplifs. -(* mod *) - apply SAME. - exploit (divs_mods_exists (rs RAX) (rs RCX)). right; congruence. - intros (nh & nl & d & q & r & A & B & C & D & E & F). - set (rs1 := nextinstr_nf (rs#RDX <- (Vint nh))). - econstructor; split. - eapply exec_straight_two with (rs2 := rs1). simpl. rewrite A. reflexivity. - simpl. change (rs1 RAX) with (rs RAX); rewrite B. - change (rs1 RCX) with (rs RCX); rewrite C. - rewrite D. reflexivity. auto. auto. - split. change (Vint r = v). congruence. - simpl; intros. destruct H2. unfold rs1; Simplifs. -(* modu *) - apply SAME. - exploit (divu_modu_exists (rs RAX) (rs RCX)). right; congruence. - intros (n & d & q & r & B & C & D & E & F). - set (rs1 := nextinstr_nf (rs#RDX <- Vzero)). - econstructor; split. - eapply exec_straight_two with (rs2 := rs1). reflexivity. - simpl. change (rs1 RAX) with (rs RAX); rewrite B. - change (rs1 RCX) with (rs RCX); rewrite C. - rewrite D. reflexivity. auto. auto. - split. change (Vint r = v). congruence. - simpl; intros. destruct H2. unfold rs1; Simplifs. -(* shrximm *) - apply SAME. eapply mk_shrximm_correct; eauto. -(* lea *) - exploit transl_addressing_mode_32_correct; eauto. intros EA. - TranslOp. rewrite nextinstr_inv; auto with asmgen. rewrite Pregmap.gss. rewrite normalize_addrmode_32_correct; auto. -(* mullhs *) - apply SAME. TranslOp. destruct H1. Simplifs. -(* mullhu *) - apply SAME. TranslOp. destruct H1. Simplifs. -(* divl *) - apply SAME. - exploit (divls_modls_exists (rs RAX) (rs RCX)). left; congruence. - intros (nh & nl & d & q & r & A & B & C & D & E & F). - set (rs1 := nextinstr_nf (rs#RDX <- (Vlong nh))). - econstructor; split. - eapply exec_straight_two with (rs2 := rs1). simpl. rewrite A. reflexivity. - simpl. change (rs1 RAX) with (rs RAX); rewrite B. - change (rs1 RCX) with (rs RCX); rewrite C. - rewrite D. reflexivity. auto. auto. - split. change (Vlong q = v). congruence. - simpl; intros. destruct H2. unfold rs1; Simplifs. -(* divlu *) - apply SAME. - exploit (divlu_modlu_exists (rs RAX) (rs RCX)). left; congruence. - intros (n & d & q & r & B & C & D & E & F). - set (rs1 := nextinstr_nf (rs#RDX <- (Vlong Int64.zero))). - econstructor; split. - eapply exec_straight_two with (rs2 := rs1). reflexivity. - simpl. change (rs1 RAX) with (rs RAX); rewrite B. - change (rs1 RCX) with (rs RCX); rewrite C. - rewrite D. reflexivity. auto. auto. - split. change (Vlong q = v). congruence. - simpl; intros. destruct H2. unfold rs1; Simplifs. -(* modl *) - apply SAME. - exploit (divls_modls_exists (rs RAX) (rs RCX)). right; congruence. - intros (nh & nl & d & q & r & A & B & C & D & E & F). - set (rs1 := nextinstr_nf (rs#RDX <- (Vlong nh))). - econstructor; split. - eapply exec_straight_two with (rs2 := rs1). simpl. rewrite A. reflexivity. - simpl. change (rs1 RAX) with (rs RAX); rewrite B. - change (rs1 RCX) with (rs RCX); rewrite C. - rewrite D. reflexivity. auto. auto. - split. change (Vlong r = v). congruence. - simpl; intros. destruct H2. unfold rs1; Simplifs. -(* modlu *) - apply SAME. - exploit (divlu_modlu_exists (rs RAX) (rs RCX)). right; congruence. - intros (n & d & q & r & B & C & D & E & F). - set (rs1 := nextinstr_nf (rs#RDX <- (Vlong Int64.zero))). - econstructor; split. - eapply exec_straight_two with (rs2 := rs1). reflexivity. - simpl. change (rs1 RAX) with (rs RAX); rewrite B. - change (rs1 RCX) with (rs RCX); rewrite C. - rewrite D. reflexivity. auto. auto. - split. change (Vlong r = v). congruence. - simpl; intros. destruct H2. unfold rs1; Simplifs. -(* shrxlimm *) - apply SAME. eapply mk_shrxlimm_correct; eauto. -(* leal *) - exploit transl_addressing_mode_64_correct; eauto. intros EA. - generalize (normalize_addrmode_64_correct x rs). destruct (normalize_addrmode_64 x) as [am' [delta|]]; intros EV. - econstructor; split. eapply exec_straight_two. - simpl. reflexivity. simpl. reflexivity. auto. auto. - split. rewrite nextinstr_nf_inv by auto. rewrite Pregmap.gss. rewrite nextinstr_inv by auto with asmgen. - rewrite Pregmap.gss. rewrite <- EV; auto. - intros; Simplifs. - TranslOp. rewrite nextinstr_inv; auto with asmgen. rewrite Pregmap.gss; auto. rewrite <- EV; auto. -(* intoffloat *) - apply SAME. TranslOp. rewrite H0; auto. -(* floatofint *) - apply SAME. TranslOp. rewrite H0; auto. -(* intofsingle *) - apply SAME. TranslOp. rewrite H0; auto. -(* singleofint *) - apply SAME. TranslOp. rewrite H0; auto. -(* longoffloat *) - apply SAME. TranslOp. rewrite H0; auto. -(* floatoflong *) - apply SAME. TranslOp. rewrite H0; auto. -(* longofsingle *) - apply SAME. TranslOp. rewrite H0; auto. -(* singleoflong *) - apply SAME. TranslOp. rewrite H0; auto. -(* condition *) - exploit transl_cond_correct; eauto. intros [rs2 [P [Q R]]]. - exploit mk_setcc_correct; eauto. intros [rs3 [S [T U]]]. - exists rs3. - split. eapply exec_straight_trans. eexact P. eexact S. - split. rewrite T. destruct (eval_condition cond rs ## (preg_of ## args) m). - rewrite Q. auto. - simpl; auto. - intros. transitivity (rs2 r); auto. -Qed. - -(** Translation of memory loads. *) - -Lemma transl_load_correct: - forall chunk addr args dest k c (rs: regset) m a v, - transl_load chunk addr args dest k = OK c -> - eval_addressing ge (rs#RSP) addr (map rs (map preg_of args)) = Some a -> - Mem.loadv chunk m a = Some v -> - exists rs', - exec_straight ge fn c rs m k rs' m - /\ rs'#(preg_of dest) = v - /\ forall r, data_preg r = true -> r <> preg_of dest -> rs'#r = rs#r. -Proof. - unfold transl_load; intros. monadInv H. - exploit transl_addressing_mode_correct; eauto. intro EA. - assert (EA': eval_addrmode ge x rs = a). destruct a; simpl in H1; try discriminate; inv EA; auto. - set (rs2 := nextinstr_nf (rs#(preg_of dest) <- v)). - assert (exec_load ge chunk m x rs (preg_of dest) = Next rs2 m). - unfold exec_load. rewrite EA'. rewrite H1. auto. - assert (rs2 PC = Val.offset_ptr (rs PC) Ptrofs.one). - transitivity (Val.offset_ptr ((rs#(preg_of dest) <- v) PC) Ptrofs.one). - auto. decEq. apply Pregmap.gso; auto with asmgen. - exists rs2. split. - destruct chunk; ArgsInv; apply exec_straight_one; auto. - split. unfold rs2. rewrite nextinstr_nf_inv1. Simplifs. apply preg_of_data. - intros. unfold rs2. Simplifs. -Qed. - -Lemma transl_store_correct: - forall chunk addr args src k c (rs: regset) m a m', - transl_store chunk addr args src k = OK c -> - eval_addressing ge (rs#RSP) addr (map rs (map preg_of args)) = Some a -> - Mem.storev chunk m a (rs (preg_of src)) = Some m' -> - exists rs', - exec_straight ge fn c rs m k rs' m' - /\ forall r, data_preg r = true -> preg_notin r (destroyed_by_store chunk addr) -> rs'#r = rs#r. -Proof. - unfold transl_store; intros. monadInv H. - exploit transl_addressing_mode_correct; eauto. intro EA. - assert (EA': eval_addrmode ge x rs = a). destruct a; simpl in H1; try discriminate; inv EA; auto. - rewrite <- EA' in H1. destruct chunk; ArgsInv. -(* int8signed *) - eapply mk_storebyte_correct; eauto. - destruct (eval_addrmode ge x rs); simpl; auto. rewrite <- Mem.store_signed_unsigned_8; auto. -(* int8unsigned *) - eapply mk_storebyte_correct; eauto. -(* int16signed *) - econstructor; split. - apply exec_straight_one. simpl. unfold exec_store. - replace (Mem.storev Mint16unsigned m (eval_addrmode ge x rs) (rs x0)) - with (Mem.storev Mint16signed m (eval_addrmode ge x rs) (rs x0)). - rewrite H1. eauto. - destruct (eval_addrmode ge x rs); simpl; auto. rewrite Mem.store_signed_unsigned_16; auto. - auto. - intros. Simplifs. -(* int16unsigned *) - econstructor; split. - apply exec_straight_one. simpl. unfold exec_store. rewrite H1. eauto. auto. - intros. Simplifs. -(* int32 *) - econstructor; split. - apply exec_straight_one. simpl. unfold exec_store. rewrite H1. eauto. auto. - intros. Simplifs. -(* int64 *) - econstructor; split. - apply exec_straight_one. simpl. unfold exec_store. rewrite H1. eauto. auto. - intros. Simplifs. -(* float32 *) - econstructor; split. - apply exec_straight_one. simpl. unfold exec_store. rewrite H1. eauto. auto. - intros. Transparent destroyed_by_store. simpl in H2. simpl. Simplifs. -(* float64 *) - econstructor; split. - apply exec_straight_one. simpl. unfold exec_store. rewrite H1. eauto. auto. - intros. Simplifs. -Qed. - -End CONSTRUCTORS. diff --git a/ia32/CBuiltins.ml b/ia32/CBuiltins.ml deleted file mode 100644 index 09303223..00000000 --- a/ia32/CBuiltins.ml +++ /dev/null @@ -1,94 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(* Processor-dependent builtin C functions *) - -open C - -let (va_list_type, va_list_scalar, size_va_list) = - if Archi.ptr64 then - (* Actually a struct passed by reference; equivalent to 3 64-bit words *) - (TArray(TInt(IULong, []), Some 3L, []), false, 3*8) - else - (* Just a pointer *) - (TPtr(TVoid [], []), true, 4) - -let builtins = { - Builtins.typedefs = [ - "__builtin_va_list", va_list_type; - ]; - Builtins.functions = [ - (* Integer arithmetic *) - "__builtin_bswap", - (TInt(IUInt, []), [TInt(IUInt, [])], false); - "__builtin_bswap64", - (TInt(IULongLong, []), [TInt(IULongLong, [])], false); - "__builtin_bswap32", - (TInt(IUInt, []), [TInt(IUInt, [])], false); - "__builtin_bswap16", - (TInt(IUShort, []), [TInt(IUShort, [])], false); - "__builtin_clz", - (TInt(IInt, []), [TInt(IUInt, [])], false); - "__builtin_clzl", - (TInt(IInt, []), [TInt(IULong, [])], false); - "__builtin_clzll", - (TInt(IInt, []), [TInt(IULongLong, [])], false); - "__builtin_ctz", - (TInt(IInt, []), [TInt(IUInt, [])], false); - "__builtin_ctzl", - (TInt(IInt, []), [TInt(IULong, [])], false); - "__builtin_ctzll", - (TInt(IInt, []), [TInt(IULongLong, [])], false); - (* Float arithmetic *) - "__builtin_fsqrt", - (TFloat(FDouble, []), [TFloat(FDouble, [])], false); - "__builtin_fmax", - (TFloat(FDouble, []), [TFloat(FDouble, []); TFloat(FDouble, [])], false); - "__builtin_fmin", - (TFloat(FDouble, []), [TFloat(FDouble, []); TFloat(FDouble, [])], false); - "__builtin_fmadd", - (TFloat(FDouble, []), - [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], - false); - "__builtin_fmsub", - (TFloat(FDouble, []), - [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], - false); - "__builtin_fnmadd", - (TFloat(FDouble, []), - [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], - false); - "__builtin_fnmsub", - (TFloat(FDouble, []), - [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], - false); - (* Memory accesses *) - "__builtin_read16_reversed", - (TInt(IUShort, []), [TPtr(TInt(IUShort, [AConst]), [])], false); - "__builtin_read32_reversed", - (TInt(IUInt, []), [TPtr(TInt(IUInt, [AConst]), [])], false); - "__builtin_write16_reversed", - (TVoid [], [TPtr(TInt(IUShort, []), []); TInt(IUShort, [])], false); - "__builtin_write32_reversed", - (TVoid [], [TPtr(TInt(IUInt, []), []); TInt(IUInt, [])], false); - (* no operation *) - "__builtin_nop", - (TVoid [], [], false); - ] -} - -(* Expand memory references inside extended asm statements. Used in C2C. *) - -let asm_mem_argument arg = Printf.sprintf "0(%s)" arg diff --git a/ia32/CombineOp.v b/ia32/CombineOp.v deleted file mode 100644 index 34c1c9cc..00000000 --- a/ia32/CombineOp.v +++ /dev/null @@ -1,150 +0,0 @@ -(* *********************************************************************) -(* *) -(* 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/ia32/CombineOpproof.v b/ia32/CombineOpproof.v deleted file mode 100644 index f59e582b..00000000 --- a/ia32/CombineOpproof.v +++ /dev/null @@ -1,179 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Recognition of combined operations, addressing modes and conditions - during the [CSE] phase. *) - -Require Import Coqlib. -Require Import Integers Values Memory. -Require Import Op RTL CSEdomain. -Require Import CombineOp. - -Section COMBINE. - -Variable ge: genv. -Variable sp: val. -Variable m: mem. -Variable get: valnum -> option rhs. -Variable valu: valnum -> val. -Hypothesis get_sound: forall v rhs, get v = Some rhs -> rhs_eval_to valu ge sp m rhs (valu v). - -Lemma get_op_sound: - forall v op vl, get v = Some (Op op vl) -> eval_operation ge sp op (map valu vl) m = Some (valu v). -Proof. - intros. exploit get_sound; eauto. intros REV; inv REV; auto. -Qed. - -Ltac UseGetSound := - match goal with - | [ H: get _ = Some _ |- _ ] => - let x := fresh "EQ" in (generalize (get_op_sound _ _ _ H); intros x; simpl in x; FuncInv) - end. - -Lemma combine_compimm_ne_0_sound: - forall x cond args, - combine_compimm_ne_0 get x = Some(cond, args) -> - eval_condition cond (map valu args) m = Val.cmp_bool Cne (valu x) (Vint Int.zero) /\ - eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Cne (valu x) (Vint Int.zero). -Proof. - intros until args. functional induction (combine_compimm_ne_0 get x); intros EQ; inv EQ. - (* of cmp *) - UseGetSound. rewrite <- H. - destruct (eval_condition cond (map valu args) m); simpl; auto. destruct b; auto. - (* of and *) - UseGetSound. rewrite <- H. - destruct v; simpl; auto. -Qed. - -Lemma combine_compimm_eq_0_sound: - forall x cond args, - combine_compimm_eq_0 get x = Some(cond, args) -> - eval_condition cond (map valu args) m = Val.cmp_bool Ceq (valu x) (Vint Int.zero) /\ - eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Ceq (valu x) (Vint Int.zero). -Proof. - intros until args. functional induction (combine_compimm_eq_0 get x); intros EQ; inv EQ. - (* of cmp *) - UseGetSound. rewrite <- H. - rewrite eval_negate_condition. - destruct (eval_condition c (map valu args) m); simpl; auto. destruct b; auto. - (* of and *) - UseGetSound. rewrite <- H. destruct v; auto. -Qed. - -Lemma combine_compimm_eq_1_sound: - forall x cond args, - combine_compimm_eq_1 get x = Some(cond, args) -> - eval_condition cond (map valu args) m = Val.cmp_bool Ceq (valu x) (Vint Int.one) /\ - eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Ceq (valu x) (Vint Int.one). -Proof. - intros until args. functional induction (combine_compimm_eq_1 get x); intros EQ; inv EQ. - (* of cmp *) - UseGetSound. rewrite <- H. - destruct (eval_condition cond (map valu args) m); simpl; auto. destruct b; auto. -Qed. - -Lemma combine_compimm_ne_1_sound: - forall x cond args, - combine_compimm_ne_1 get x = Some(cond, args) -> - eval_condition cond (map valu args) m = Val.cmp_bool Cne (valu x) (Vint Int.one) /\ - eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Cne (valu x) (Vint Int.one). -Proof. - intros until args. functional induction (combine_compimm_ne_1 get x); intros EQ; inv EQ. - (* of cmp *) - UseGetSound. rewrite <- H. - rewrite eval_negate_condition. - destruct (eval_condition c (map valu args) m); simpl; auto. destruct b; auto. -Qed. - -Theorem combine_cond_sound: - forall cond args cond' args', - combine_cond get cond args = Some(cond', args') -> - eval_condition cond' (map valu args') m = eval_condition cond (map valu args) m. -Proof. - intros. functional inversion H; subst. - (* compimm ne zero *) - simpl; eapply combine_compimm_ne_0_sound; eauto. - (* compimm ne one *) - simpl; eapply combine_compimm_ne_1_sound; eauto. - (* compimm eq zero *) - simpl; eapply combine_compimm_eq_0_sound; eauto. - (* compimm eq one *) - simpl; eapply combine_compimm_eq_1_sound; eauto. - (* compuimm ne zero *) - simpl; eapply combine_compimm_ne_0_sound; eauto. - (* compuimm ne one *) - simpl; eapply combine_compimm_ne_1_sound; eauto. - (* compuimm eq zero *) - simpl; eapply combine_compimm_eq_0_sound; eauto. - (* compuimm eq one *) - simpl; eapply combine_compimm_eq_1_sound; eauto. -Qed. - -Theorem combine_addr_32_sound: - forall addr args addr' args', - combine_addr_32 get addr args = Some(addr', args') -> - eval_addressing32 ge sp addr' (map valu args') = eval_addressing32 ge sp addr (map valu args). -Proof. - intros. functional inversion H; subst. - (* indexed - lea *) - UseGetSound. simpl. unfold offset_addressing in H7. destruct (addressing_valid (offset_addressing_total a n)); inv H7. - eapply eval_offset_addressing_total_32; eauto. -Qed. - -Theorem combine_addr_64_sound: - forall addr args addr' args', - combine_addr_64 get addr args = Some(addr', args') -> - eval_addressing64 ge sp addr' (map valu args') = eval_addressing64 ge sp addr (map valu args). -Proof. - intros. functional inversion H; subst. - (* indexed - leal *) - UseGetSound. simpl. unfold offset_addressing in H7. destruct (addressing_valid (offset_addressing_total a n)); inv H7. - eapply eval_offset_addressing_total_64; eauto. -Qed. - -Theorem combine_addr_sound: - forall addr args addr' args', - combine_addr get addr args = Some(addr', args') -> - eval_addressing ge sp addr' (map valu args') = eval_addressing ge sp addr (map valu args). -Proof. - unfold combine_addr, eval_addressing; intros; destruct Archi.ptr64. - apply combine_addr_64_sound; auto. - apply combine_addr_32_sound; auto. -Qed. - -Theorem combine_op_sound: - forall op args op' args', - combine_op get op args = Some(op', args') -> - eval_operation ge sp op' (map valu args') m = eval_operation ge sp op (map valu args) m. -Proof. - intros. functional inversion H; subst. -(* lea-lea *) - simpl. eapply combine_addr_32_sound; eauto. -(* leal-leal *) - simpl. eapply combine_addr_64_sound; eauto. -(* andimm - andimm *) - UseGetSound; simpl. rewrite <- H0. rewrite Val.and_assoc. auto. -(* orimm - orimm *) - UseGetSound; simpl. rewrite <- H0. rewrite Val.or_assoc. auto. -(* xorimm - xorimm *) - UseGetSound; simpl. rewrite <- H0. rewrite Val.xor_assoc. auto. -(* andimm - andimm *) - UseGetSound; simpl. rewrite <- H0. rewrite Val.andl_assoc. auto. -(* orimm - orimm *) - UseGetSound; simpl. rewrite <- H0. rewrite Val.orl_assoc. auto. -(* xorimm - xorimm *) - UseGetSound; simpl. rewrite <- H0. rewrite Val.xorl_assoc. auto. -(* cmp *) - simpl. decEq; decEq. eapply combine_cond_sound; eauto. -Qed. - -End COMBINE. diff --git a/ia32/ConstpropOp.vp b/ia32/ConstpropOp.vp deleted file mode 100644 index 0bf143d2..00000000 --- a/ia32/ConstpropOp.vp +++ /dev/null @@ -1,404 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Strength reduction for operators and conditions. - This is the machine-dependent part of [Constprop]. *) - -Require Import Coqlib Compopts. -Require Import AST Integers Floats. -Require Import Op Registers. -Require Import ValueDomain. - -(** * Converting known values to constants *) - -Parameter symbol_is_external: ident -> bool. (**r See [SelectOp] *) - -Definition Olea_ptr (a: addressing) := if Archi.ptr64 then Oleal a else Olea a. - -Definition const_for_result (a: aval) : option operation := - match a with - | I n => Some(Ointconst n) - | L n => if Archi.ptr64 then Some(Olongconst n) else None - | F n => if Compopts.generate_float_constants tt then Some(Ofloatconst n) else None - | FS n => if Compopts.generate_float_constants tt then Some(Osingleconst n) else None - | Ptr(Gl id ofs) => - if symbol_is_external id then - if Ptrofs.eq ofs Ptrofs.zero then Some (Oindirectsymbol id) else None - else - Some (Olea_ptr (Aglobal id ofs)) - | Ptr(Stk ofs) => Some(Olea_ptr (Ainstack ofs)) - | _ => None - end. - -(** * Operator strength reduction *) - -(** We now define auxiliary functions for strength reduction of - operators and addressing modes: replacing an operator with a cheaper - one if some of its arguments are statically known. These are again - large pattern-matchings expressed in indirect style. *) - -Nondetfunction cond_strength_reduction - (cond: condition) (args: list reg) (vl: list aval) := - match cond, args, vl with - | Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil => - (Ccompimm (swap_comparison c) n1, r2 :: nil) - | Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil => - (Ccompimm c n2, r1 :: nil) - | Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil => - (Ccompuimm (swap_comparison c) n1, r2 :: nil) - | Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil => - (Ccompuimm c n2, r1 :: nil) - | Ccompl c, r1 :: r2 :: nil, L n1 :: v2 :: nil => - (Ccomplimm (swap_comparison c) n1, r2 :: nil) - | Ccompl c, r1 :: r2 :: nil, v1 :: L n2 :: nil => - (Ccomplimm c n2, r1 :: nil) - | Ccomplu c, r1 :: r2 :: nil, L n1 :: v2 :: nil => - (Ccompluimm (swap_comparison c) n1, r2 :: nil) - | Ccomplu c, r1 :: r2 :: nil, v1 :: L n2 :: nil => - (Ccompluimm c n2, r1 :: nil) - | _, _, _ => - (cond, args) - end. - -Definition make_cmp_base (c: condition) (args: list reg) (vl: list aval) := - let (c', args') := cond_strength_reduction c args vl in (Ocmp c', args'). - -Nondetfunction make_cmp (c: condition) (args: list reg) (vl: list aval) := - match c, args, vl with - | Ccompimm Ceq n, r1 :: nil, v1 :: nil => - if Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1) then (Omove, r1 :: nil) - else if Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1) then (Oxorimm Int.one, r1 :: nil) - else make_cmp_base c args vl - | Ccompimm Cne n, r1 :: nil, v1 :: nil => - if Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1) then (Omove, r1 :: nil) - else if Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1) then (Oxorimm Int.one, r1 :: nil) - else make_cmp_base c args vl - | _, _, _ => - make_cmp_base c args vl - end. - -(** For addressing modes, we need to distinguish -- reductions that produce pointers (i.e. that produce [Aglobal], [Ainstack], [Abased] and [Abasedscaled] addressing modes), which are valid only if the pointer size is right; -- other reductions (producing [Aindexed] or [Aindexed2] modes), which are valid independently of the pointer size. -*) - -Nondetfunction addr_strength_reduction_32_generic - (addr: addressing) (args: list reg) (vl: list aval) := - match addr, args, vl with - | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: v2 :: nil => - (Aindexed (Int.signed n1 + ofs), r2 :: nil) - | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil => - (Aindexed (Int.signed n2 + ofs), r1 :: nil) - | Aindexed2scaled sc ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil => - (Aindexed (Int.signed n2 * sc + ofs), r1 :: nil) - | Aindexed2scaled sc ofs, r1 :: r2 :: nil, I n1 :: v2 :: nil => - (Ascaled sc (Int.signed n1 + ofs), r2 :: nil) - | _, _ => - (addr, args) - end. - -Nondetfunction addr_strength_reduction_32 - (addr: addressing) (args: list reg) (vl: list aval) := - - if Archi.ptr64 then addr_strength_reduction_32_generic addr args vl else - - match addr, args, vl with - - | Aindexed ofs, r1 :: nil, Ptr(Gl symb n) :: nil => - (Aglobal symb (Ptrofs.add n (Ptrofs.repr ofs)), nil) - | Aindexed ofs, r1 :: nil, Ptr(Stk n) :: nil => - (Ainstack (Ptrofs.add n (Ptrofs.repr ofs)), nil) - - | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: I n2 :: nil => - (Aglobal symb (Ptrofs.add (Ptrofs.add n1 (Ptrofs.of_int n2)) (Ptrofs.repr ofs)), nil) - | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: Ptr(Gl symb n2) :: nil => - (Aglobal symb (Ptrofs.add (Ptrofs.add n2 (Ptrofs.of_int n1)) (Ptrofs.repr ofs)), nil) - | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Stk n1) :: I n2 :: nil => - (Ainstack (Ptrofs.add (Ptrofs.add n1 (Ptrofs.of_int n2)) (Ptrofs.repr ofs)), nil) - | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: Ptr(Stk n2) :: nil => - (Ainstack (Ptrofs.add (Ptrofs.add (Ptrofs.of_int n1) n2) (Ptrofs.repr ofs)), nil) - | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: v2 :: nil => - (Abased symb (Ptrofs.add n1 (Ptrofs.repr ofs)), r2 :: nil) - | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: Ptr(Gl symb n2) :: nil => - (Abased symb (Ptrofs.add n2 (Ptrofs.repr ofs)), r1 :: nil) - - | Aindexed2scaled sc ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: I n2 :: nil => - (Aglobal symb (Ptrofs.add (Ptrofs.add n1 (Ptrofs.of_int (Int.mul n2 (Int.repr sc)))) (Ptrofs.repr ofs)), nil) - - | Aindexed2scaled sc ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: v2 :: nil => - (Abasedscaled sc symb (Ptrofs.add n1 (Ptrofs.repr ofs)), r2 :: nil) - - | Abased id ofs, r1 :: nil, I n1 :: nil => - (Aglobal id (Ptrofs.add ofs (Ptrofs.of_int n1)), nil) - - | Abasedscaled sc id ofs, r1 :: nil, I n1 :: nil => - (Aglobal id (Ptrofs.add ofs (Ptrofs.of_int (Int.mul n1 (Int.repr sc)))), nil) - - | _, _ => - addr_strength_reduction_32_generic addr args vl - end. - -Nondetfunction addr_strength_reduction_64_generic - (addr: addressing) (args: list reg) (vl: list aval) := - match addr, args, vl with - | Aindexed2 ofs, r1 :: r2 :: nil, L n1 :: v2 :: nil => - (Aindexed (Int64.signed n1 + ofs), r2 :: nil) - | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: L n2 :: nil => - (Aindexed (Int64.signed n2 + ofs), r1 :: nil) - | Aindexed2scaled sc ofs, r1 :: r2 :: nil, v1 :: L n2 :: nil => - (Aindexed (Int64.signed n2 * sc + ofs), r1 :: nil) - | Aindexed2scaled sc ofs, r1 :: r2 :: nil, L n1 :: v2 :: nil => - (Ascaled sc (Int64.signed n1 + ofs), r2 :: nil) - | _, _ => - (addr, args) - end. - -Nondetfunction addr_strength_reduction_64 - (addr: addressing) (args: list reg) (vl: list aval) := - - if negb Archi.ptr64 then addr_strength_reduction_64_generic addr args vl else - - match addr, args, vl with - - | Aindexed ofs, r1 :: nil, Ptr(Gl symb n) :: nil => - (Aglobal symb (Ptrofs.add n (Ptrofs.repr ofs)), nil) - | Aindexed ofs, r1 :: nil, Ptr(Stk n) :: nil => - (Ainstack (Ptrofs.add n (Ptrofs.repr ofs)), nil) - - | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: L n2 :: nil => - (Aglobal symb (Ptrofs.add (Ptrofs.add n1 (Ptrofs.of_int64 n2)) (Ptrofs.repr ofs)), nil) - | Aindexed2 ofs, r1 :: r2 :: nil, L n1 :: Ptr(Gl symb n2) :: nil => - (Aglobal symb (Ptrofs.add (Ptrofs.add n2 (Ptrofs.of_int64 n1)) (Ptrofs.repr ofs)), nil) - | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Stk n1) :: L n2 :: nil => - (Ainstack (Ptrofs.add (Ptrofs.add n1 (Ptrofs.of_int64 n2)) (Ptrofs.repr ofs)), nil) - | Aindexed2 ofs, r1 :: r2 :: nil, L n1 :: Ptr(Stk n2) :: nil => - (Ainstack (Ptrofs.add (Ptrofs.add (Ptrofs.of_int64 n1) n2) (Ptrofs.repr ofs)), nil) - - | Aindexed2scaled sc ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: L n2 :: nil => - (Aglobal symb (Ptrofs.add (Ptrofs.add n1 (Ptrofs.of_int64 (Int64.mul n2 (Int64.repr sc)))) (Ptrofs.repr ofs)), nil) - - | _, _ => - addr_strength_reduction_64_generic addr args vl - end. - -Definition addr_strength_reduction - (addr: addressing) (args: list reg) (vl: list aval) := - if Archi.ptr64 - then addr_strength_reduction_64 addr args vl - else addr_strength_reduction_32 addr args vl. - -Definition make_addimm (n: int) (r: reg) := - if Int.eq n Int.zero - then (Omove, r :: nil) - else (Olea (Aindexed (Int.signed n)), r :: nil). - -Definition make_shlimm (n: int) (r1 r2: reg) := - if Int.eq n Int.zero then (Omove, r1 :: nil) - else if Int.ltu n Int.iwordsize then (Oshlimm n, r1 :: nil) - else (Oshl, r1 :: r2 :: nil). - -Definition make_shrimm (n: int) (r1 r2: reg) := - if Int.eq n Int.zero then (Omove, r1 :: nil) - else if Int.ltu n Int.iwordsize then (Oshrimm n, r1 :: nil) - else (Oshr, r1 :: r2 :: nil). - -Definition make_shruimm (n: int) (r1 r2: reg) := - if Int.eq n Int.zero then (Omove, r1 :: nil) - else if Int.ltu n Int.iwordsize then (Oshruimm n, r1 :: nil) - else (Oshru, r1 :: r2 :: nil). - -Definition make_mulimm (n: int) (r: reg) := - if Int.eq n Int.zero then - (Ointconst Int.zero, nil) - else if Int.eq n Int.one then - (Omove, r :: nil) - else - match Int.is_power2 n with - | Some l => (Oshlimm l, r :: nil) - | None => (Omulimm n, r :: nil) - end. - -Definition make_andimm (n: int) (r: reg) (a: aval) := - if Int.eq n Int.zero then (Ointconst Int.zero, nil) - else if Int.eq n Int.mone then (Omove, r :: nil) - else if match a with Uns _ m => Int.eq (Int.zero_ext m (Int.not n)) Int.zero - | _ => false end - then (Omove, r :: nil) - else (Oandimm n, r :: nil). - -Definition make_orimm (n: int) (r: reg) := - if Int.eq n Int.zero then (Omove, r :: nil) - else if Int.eq n Int.mone then (Ointconst Int.mone, nil) - else (Oorimm n, r :: nil). - -Definition make_xorimm (n: int) (r: reg) := - if Int.eq n Int.zero then (Omove, r :: nil) - else if Int.eq n Int.mone then (Onot, r :: nil) - else (Oxorimm n, r :: nil). - -Definition make_divimm n (r1 r2: reg) := - match Int.is_power2 n with - | Some l => if Int.ltu l (Int.repr 31) - then (Oshrximm l, r1 :: nil) - else (Odiv, r1 :: r2 :: nil) - | None => (Odiv, r1 :: r2 :: nil) - end. - -Definition make_divuimm n (r1 r2: reg) := - match Int.is_power2 n with - | Some l => (Oshruimm l, r1 :: nil) - | None => (Odivu, r1 :: r2 :: nil) - end. - -Definition make_moduimm n (r1 r2: reg) := - match Int.is_power2 n with - | Some l => (Oandimm (Int.sub n Int.one), r1 :: nil) - | None => (Omodu, r1 :: r2 :: nil) - end. - -Definition make_addlimm (n: int64) (r: reg) := - if Int64.eq n Int64.zero - then (Omove, r :: nil) - else (Oleal (Aindexed (Int64.signed n)), r :: nil). - -Definition make_shllimm (n: int) (r1 r2: reg) := - if Int.eq n Int.zero then (Omove, r1 :: nil) - else if Int.ltu n Int64.iwordsize' then (Oshllimm n, r1 :: nil) - else (Oshll, r1 :: r2 :: nil). - -Definition make_shrlimm (n: int) (r1 r2: reg) := - if Int.eq n Int.zero then (Omove, r1 :: nil) - else if Int.ltu n Int64.iwordsize' then (Oshrlimm n, r1 :: nil) - else (Oshrl, r1 :: r2 :: nil). - -Definition make_shrluimm (n: int) (r1 r2: reg) := - if Int.eq n Int.zero then (Omove, r1 :: nil) - else if Int.ltu n Int64.iwordsize' then (Oshrluimm n, r1 :: nil) - else (Oshrlu, r1 :: r2 :: nil). - -Definition make_mullimm (n: int64) (r: reg) := - if Int64.eq n Int64.zero then - (Olongconst Int64.zero, nil) - else if Int64.eq n Int64.one then - (Omove, r :: nil) - else - match Int64.is_power2' n with - | Some l => (Oshllimm l, r :: nil) - | None => (Omullimm n, r :: nil) - end. - -Definition make_andlimm (n: int64) (r: reg) (a: aval) := - if Int64.eq n Int64.zero then (Olongconst Int64.zero, nil) - else if Int64.eq n Int64.mone then (Omove, r :: nil) - else (Oandlimm n, r :: nil). - -Definition make_orlimm (n: int64) (r: reg) := - if Int64.eq n Int64.zero then (Omove, r :: nil) - else if Int64.eq n Int64.mone then (Olongconst Int64.mone, nil) - else (Oorlimm n, r :: nil). - -Definition make_xorlimm (n: int64) (r: reg) := - if Int64.eq n Int64.zero then (Omove, r :: nil) - else if Int64.eq n Int64.mone then (Onotl, r :: nil) - else (Oxorlimm n, r :: nil). - -Definition make_divlimm n (r1 r2: reg) := - match Int64.is_power2' n with - | Some l => if Int.ltu l (Int.repr 63) - then (Oshrxlimm l, r1 :: nil) - else (Odivl, r1 :: r2 :: nil) - | None => (Odivl, r1 :: r2 :: nil) - end. - -Definition make_divluimm n (r1 r2: reg) := - match Int64.is_power2' n with - | Some l => (Oshrluimm l, r1 :: nil) - | None => (Odivlu, r1 :: r2 :: nil) - end. - -Definition make_modluimm n (r1 r2: reg) := - match Int64.is_power2 n with - | Some l => (Oandlimm (Int64.sub n Int64.one), r1 :: nil) - | None => (Omodlu, r1 :: r2 :: nil) - end. - -Definition make_mulfimm (n: float) (r r1 r2: reg) := - if Float.eq_dec n (Float.of_int (Int.repr 2)) - then (Oaddf, r :: r :: nil) - else (Omulf, r1 :: r2 :: nil). - -Definition make_mulfsimm (n: float32) (r r1 r2: reg) := - if Float32.eq_dec n (Float32.of_int (Int.repr 2)) - then (Oaddfs, r :: r :: nil) - else (Omulfs, r1 :: r2 :: nil). - -Definition make_cast8signed (r: reg) (a: aval) := - if vincl a (Sgn Ptop 8) then (Omove, r :: nil) else (Ocast8signed, r :: nil). -Definition make_cast8unsigned (r: reg) (a: aval) := - if vincl a (Uns Ptop 8) then (Omove, r :: nil) else (Ocast8unsigned, r :: nil). -Definition make_cast16signed (r: reg) (a: aval) := - if vincl a (Sgn Ptop 16) then (Omove, r :: nil) else (Ocast16signed, r :: nil). -Definition make_cast16unsigned (r: reg) (a: aval) := - if vincl a (Uns Ptop 16) then (Omove, r :: nil) else (Ocast16unsigned, r :: nil). - -Nondetfunction op_strength_reduction - (op: operation) (args: list reg) (vl: list aval) := - match op, args, vl with - | Ocast8signed, r1 :: nil, v1 :: nil => make_cast8signed r1 v1 - | Ocast8unsigned, r1 :: nil, v1 :: nil => make_cast8unsigned r1 v1 - | Ocast16signed, r1 :: nil, v1 :: nil => make_cast16signed r1 v1 - | Ocast16unsigned, r1 :: nil, v1 :: nil => make_cast16unsigned r1 v1 - | Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm (Int.neg n2) r1 - | Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_mulimm n1 r2 - | Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_mulimm n2 r1 - | Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divimm n2 r1 r2 - | Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divuimm n2 r1 r2 - | Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_moduimm n2 r1 r2 - | Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_andimm n1 r2 v2 - | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm n2 r1 v1 - | Oandimm n, r1 :: nil, v1 :: nil => make_andimm n r1 v1 - | Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_orimm n1 r2 - | Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_orimm n2 r1 - | Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_xorimm n1 r2 - | Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_xorimm n2 r1 - | Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shlimm n2 r1 r2 - | Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrimm n2 r1 r2 - | Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shruimm n2 r1 r2 - | Olea addr, args, vl => - let (addr', args') := addr_strength_reduction_32 addr args vl in - (Olea addr', args') - | Osubl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_addlimm (Int64.neg n2) r1 - | Omull, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_mullimm n1 r2 - | Omull, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_mullimm n2 r1 - | Odivl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_divlimm n2 r1 r2 - | Odivlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_divluimm n2 r1 r2 - | Omodlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_modluimm n2 r1 r2 - | Oandl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_andlimm n1 r2 v2 - | Oandl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_andlimm n2 r1 v1 - | Oandlimm n, r1 :: nil, v1 :: nil => make_andlimm n r1 v1 - | Oorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_orlimm n1 r2 - | Oorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_orlimm n2 r1 - | Oxorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_xorlimm n1 r2 - | Oxorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_xorlimm n2 r1 - | Oshll, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shllimm n2 r1 r2 - | Oshrl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrlimm n2 r1 r2 - | Oshrlu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrluimm n2 r1 r2 - | Oleal addr, args, vl => - let (addr', args') := addr_strength_reduction_64 addr args vl in - (Oleal addr', args') - | Ocmp c, args, vl => make_cmp c args vl - | Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil => make_mulfimm n2 r1 r1 r2 - | Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil => make_mulfimm n1 r2 r1 r2 - | Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil => make_mulfsimm n2 r1 r1 r2 - | Omulfs, r1 :: r2 :: nil, FS n1 :: v2 :: nil => make_mulfsimm n1 r2 r1 r2 - | _, _, _ => (op, args) - end. diff --git a/ia32/ConstpropOpproof.v b/ia32/ConstpropOpproof.v deleted file mode 100644 index 161b9579..00000000 --- a/ia32/ConstpropOpproof.v +++ /dev/null @@ -1,881 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Correctness proof for operator strength reduction. *) - -Require Import Coqlib Compopts. -Require Import Integers Floats Values Memory Globalenvs Events. -Require Import Op Registers RTL ValueDomain. -Require Import ConstpropOp. - -Section STRENGTH_REDUCTION. - -Variable bc: block_classification. -Variable ge: genv. -Hypothesis GENV: genv_match bc ge. -Variable sp: block. -Hypothesis STACK: bc sp = BCstack. -Variable ae: AE.t. -Variable e: regset. -Variable m: mem. -Hypothesis MATCH: ematch bc e ae. - -Lemma match_G: - forall r id ofs, - AE.get r ae = Ptr(Gl id ofs) -> Val.lessdef e#r (Genv.symbol_address ge id ofs). -Proof. - intros. apply vmatch_ptr_gl with bc; auto. rewrite <- H. apply MATCH. -Qed. - -Lemma match_S: - forall r ofs, - AE.get r ae = Ptr(Stk ofs) -> Val.lessdef e#r (Vptr sp ofs). -Proof. - intros. apply vmatch_ptr_stk with bc; auto. rewrite <- H. apply MATCH. -Qed. - -Ltac InvApproxRegs := - match goal with - | [ H: _ :: _ = _ :: _ |- _ ] => - injection H; clear H; intros; InvApproxRegs - | [ H: ?v = AE.get ?r ae |- _ ] => - generalize (MATCH r); rewrite <- H; clear H; intro; InvApproxRegs - | _ => idtac - end. - -Ltac SimplVM := - match goal with - | [ H: vmatch _ ?v (I ?n) |- _ ] => - let E := fresh in - assert (E: v = Vint n) by (inversion H; auto); - rewrite E in *; clear H; SimplVM - | [ H: vmatch _ ?v (L ?n) |- _ ] => - let E := fresh in - assert (E: v = Vlong n) by (inversion H; auto); - rewrite E in *; clear H; SimplVM - | [ H: vmatch _ ?v (F ?n) |- _ ] => - let E := fresh in - assert (E: v = Vfloat n) by (inversion H; auto); - rewrite E in *; clear H; SimplVM - | [ H: vmatch _ ?v (FS ?n) |- _ ] => - let E := fresh in - assert (E: v = Vsingle n) by (inversion H; auto); - rewrite E in *; clear H; SimplVM - | [ H: vmatch _ ?v (Ptr(Gl ?id ?ofs)) |- _ ] => - let E := fresh in - assert (E: Val.lessdef v (Genv.symbol_address ge id ofs)) by (eapply vmatch_ptr_gl; eauto); - clear H; SimplVM - | [ H: vmatch _ ?v (Ptr(Stk ?ofs)) |- _ ] => - let E := fresh in - assert (E: Val.lessdef v (Vptr sp ofs)) by (eapply vmatch_ptr_stk; eauto); - clear H; SimplVM - | _ => idtac - end. - -Lemma eval_Olea_ptr: - forall a el, - eval_operation ge (Vptr sp Ptrofs.zero) (Olea_ptr a) el m = eval_addressing ge (Vptr sp Ptrofs.zero) a el. -Proof. - unfold Olea_ptr, eval_addressing; intros. destruct Archi.ptr64; auto. -Qed. - -Lemma const_for_result_correct: - forall a op v, - const_for_result a = Some op -> - vmatch bc v a -> - exists v', eval_operation ge (Vptr sp Ptrofs.zero) op nil m = Some v' /\ Val.lessdef v v'. -Proof. - unfold const_for_result; intros. - destruct a; inv H; SimplVM. -- (* integer *) - exists (Vint n); auto. -- (* long *) - destruct Archi.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; auto. - rewrite eval_Olea_ptr. apply eval_addressing_Aglobal. - + (* stack *) - inv H2. exists (Vptr sp ofs); split; auto. - rewrite eval_Olea_ptr. rewrite eval_addressing_Ainstack. - simpl. rewrite Ptrofs.add_zero_l; 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; try (inv EA); 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. -- rewrite SF in H1; inv H1. econstructor; split; eauto. - rewrite Genv.shift_symbol_address_32 by auto. auto. -- rewrite SF in H1; inv H1. 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; try (inv EA); rewrite ? SF. -- econstructor; split; eauto. rewrite B. apply Val.addl_lessdef; auto. -- econstructor; split; eauto. rewrite Ptrofs.add_zero_l. -Local Transparent Val.addl. - inv H0; auto. rewrite H2. simpl; rewrite SF, A. auto. -- econstructor; split; eauto. - unfold Ptrofs.add at 2. rewrite B. - fold (Ptrofs.add n1 (Ptrofs.of_int64 n2)). - rewrite Genv.shift_symbol_address_64 by auto. - rewrite ! Val.addl_assoc. apply Val.addl_lessdef; auto. -- econstructor; split; eauto. - unfold Ptrofs.add at 2. rewrite B. - fold (Ptrofs.add n2 (Ptrofs.of_int64 n1)). - rewrite Genv.shift_symbol_address_64 by auto. - rewrite ! Val.addl_assoc. rewrite Val.addl_permut. apply Val.addl_lessdef; auto. -- econstructor; split; eauto. rewrite Ptrofs.add_zero_l. rewrite Val.addl_assoc. - eapply Val.lessdef_trans. apply Val.addl_lessdef; eauto. - simpl. rewrite SF. rewrite Ptrofs.add_assoc. apply Val.lessdef_same; do 3 f_equal. auto with ptrofs. -- econstructor; split; eauto. rewrite Ptrofs.add_zero_l. rewrite Val.addl_assoc, Val.addl_permut. - eapply Val.lessdef_trans. apply Val.addl_lessdef; eauto. - simpl. rewrite SF. rewrite <- (Ptrofs.add_commut n2). rewrite Ptrofs.add_assoc. - apply Val.lessdef_same; do 3 f_equal. auto with ptrofs. -- econstructor; split; eauto. rewrite B. rewrite Genv.shift_symbol_address_64 by auto. - rewrite ! Val.addl_assoc. apply Val.addl_lessdef; auto. -- apply addr_strength_reduction_64_generic_correct; auto. -Qed. - -Lemma addr_strength_reduction_correct: - forall addr args vl res, - vl = map (fun r => AE.get r ae) args -> - eval_addressing ge (Vptr sp Ptrofs.zero) addr e##args = Some res -> - let (addr', args') := addr_strength_reduction addr args vl in - exists res', eval_addressing ge (Vptr sp Ptrofs.zero) addr' e##args' = Some res' /\ Val.lessdef res res'. -Proof. - unfold eval_addressing, addr_strength_reduction. destruct Archi.ptr64. - apply addr_strength_reduction_64_correct. - apply addr_strength_reduction_32_correct. -Qed. - -Lemma make_cmp_base_correct: - forall c args vl, - vl = map (fun r => AE.get r ae) args -> - let (op', args') := make_cmp_base c args vl in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some v - /\ Val.lessdef (Val.of_optbool (eval_condition c e##args m)) v. -Proof. - intros. unfold make_cmp_base. - generalize (cond_strength_reduction_correct c args vl H). - destruct (cond_strength_reduction c args vl) as [c' args']. intros EQ. - econstructor; split. simpl; eauto. rewrite EQ. auto. -Qed. - -Lemma make_cmp_correct: - forall c args vl, - vl = map (fun r => AE.get r ae) args -> - let (op', args') := make_cmp c args vl in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some v - /\ Val.lessdef (Val.of_optbool (eval_condition c e##args m)) v. -Proof. - intros c args vl. - assert (Y: forall r, vincl (AE.get r ae) (Uns Ptop 1) = true -> - e#r = Vundef \/ e#r = Vint Int.zero \/ e#r = Vint Int.one). - { intros. apply vmatch_Uns_1 with bc Ptop. eapply vmatch_ge. eapply vincl_ge; eauto. apply MATCH. } - unfold make_cmp. case (make_cmp_match c args vl); intros. -- destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1. - simpl in H; inv H. InvBooleans. subst n. - exists (e#r1); split; auto. simpl. - exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. - destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0. - simpl in H; inv H. InvBooleans. subst n. - exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl. - exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. - apply make_cmp_base_correct; auto. -- destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0. - simpl in H; inv H. InvBooleans. subst n. - exists (e#r1); split; auto. simpl. - exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. - destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1. - simpl in H; inv H. InvBooleans. subst n. - exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl. - exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. - apply make_cmp_base_correct; auto. -- apply make_cmp_base_correct; auto. -Qed. - -Lemma make_addimm_correct: - forall n r, - let (op, args) := make_addimm n r in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.add e#r (Vint n)) v. -Proof. - intros. unfold make_addimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. - subst. exists (e#r); split; auto. - destruct (e#r); simpl; auto. rewrite Int.add_zero; auto. destruct Archi.ptr64; auto. rewrite Ptrofs.add_zero; auto. - exists (Val.add e#r (Vint n)); split; auto. simpl. rewrite Int.repr_signed; auto. -Qed. - -Lemma make_shlimm_correct: - forall n r1 r2, - e#r2 = Vint n -> - let (op, args) := make_shlimm n r1 r2 in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shl e#r1 (Vint n)) v. -Proof. - intros; unfold make_shlimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. - exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shl_zero. auto. - destruct (Int.ltu n Int.iwordsize). - econstructor; split. simpl. eauto. auto. - econstructor; split. simpl. eauto. rewrite H; auto. -Qed. - -Lemma make_shrimm_correct: - forall n r1 r2, - e#r2 = Vint n -> - let (op, args) := make_shrimm n r1 r2 in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shr e#r1 (Vint n)) v. -Proof. - intros; unfold make_shrimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. - exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shr_zero. auto. - destruct (Int.ltu n Int.iwordsize). - econstructor; split. simpl. eauto. auto. - econstructor; split. simpl. eauto. rewrite H; auto. -Qed. - -Lemma make_shruimm_correct: - forall n r1 r2, - e#r2 = Vint n -> - let (op, args) := make_shruimm n r1 r2 in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shru e#r1 (Vint n)) v. -Proof. - intros; unfold make_shruimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. - exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shru_zero. auto. - destruct (Int.ltu n Int.iwordsize). - econstructor; split. simpl. eauto. auto. - econstructor; split. simpl. eauto. rewrite H; auto. -Qed. - -Lemma make_mulimm_correct: - forall n r1, - let (op, args) := make_mulimm n r1 in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mul e#r1 (Vint n)) v. -Proof. - intros; unfold make_mulimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. - exists (Vint Int.zero); split; auto. destruct (e#r1); simpl; auto. rewrite Int.mul_zero; auto. - predSpec Int.eq Int.eq_spec n Int.one; intros. subst. - exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.mul_one; auto. - destruct (Int.is_power2 n) eqn:?; intros. - rewrite (Val.mul_pow2 e#r1 _ _ Heqo). econstructor; split. simpl; eauto. auto. - econstructor; split; eauto. auto. -Qed. - -Lemma make_divimm_correct: - forall n r1 r2 v, - Val.divs e#r1 e#r2 = Some v -> - e#r2 = Vint n -> - let (op, args) := make_divimm n r1 r2 in - exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. -Proof. - intros; unfold make_divimm. - destruct (Int.is_power2 n) eqn:?. - destruct (Int.ltu i (Int.repr 31)) eqn:?. - exists v; split; auto. simpl. eapply Val.divs_pow2; eauto. congruence. - exists v; auto. - exists v; auto. -Qed. - -Lemma make_divuimm_correct: - forall n r1 r2 v, - Val.divu e#r1 e#r2 = Some v -> - e#r2 = Vint n -> - let (op, args) := make_divuimm n r1 r2 in - exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. -Proof. - intros; unfold make_divuimm. - destruct (Int.is_power2 n) eqn:?. - econstructor; split. simpl; eauto. - rewrite H0 in H. erewrite Val.divu_pow2 by eauto. auto. - exists v; auto. -Qed. - -Lemma make_moduimm_correct: - forall n r1 r2 v, - Val.modu e#r1 e#r2 = Some v -> - e#r2 = Vint n -> - let (op, args) := make_moduimm n r1 r2 in - exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. -Proof. - intros; unfold make_moduimm. - destruct (Int.is_power2 n) eqn:?. - exists v; split; auto. simpl. decEq. eapply Val.modu_pow2; eauto. congruence. - exists v; auto. -Qed. - -Lemma make_andimm_correct: - forall n r x, - vmatch bc e#r x -> - let (op, args) := make_andimm n r x in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.and e#r (Vint n)) v. -Proof. - intros; unfold make_andimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. - subst n. exists (Vint Int.zero); split; auto. destruct (e#r); simpl; auto. rewrite Int.and_zero; auto. - predSpec Int.eq Int.eq_spec n Int.mone; intros. - subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.and_mone; auto. - destruct (match x with Uns _ k => Int.eq (Int.zero_ext k (Int.not n)) Int.zero - | _ => false end) eqn:UNS. - destruct x; try congruence. - exists (e#r); split; auto. - inv H; auto. simpl. replace (Int.and i n) with i; auto. - generalize (Int.eq_spec (Int.zero_ext n0 (Int.not n)) Int.zero); rewrite UNS; intro EQ. - Int.bit_solve. destruct (zlt i0 n0). - replace (Int.testbit n i0) with (negb (Int.testbit Int.zero i0)). - rewrite Int.bits_zero. simpl. rewrite andb_true_r. auto. - rewrite <- EQ. rewrite Int.bits_zero_ext by omega. rewrite zlt_true by auto. - rewrite Int.bits_not by auto. apply negb_involutive. - rewrite H6 by auto. auto. - econstructor; split; eauto. auto. -Qed. - -Lemma make_orimm_correct: - forall n r, - let (op, args) := make_orimm n r in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.or e#r (Vint n)) v. -Proof. - intros; unfold make_orimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. - subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.or_zero; auto. - predSpec Int.eq Int.eq_spec n Int.mone; intros. - subst n. exists (Vint Int.mone); split; auto. destruct (e#r); simpl; auto. rewrite Int.or_mone; auto. - econstructor; split; eauto. auto. -Qed. - -Lemma make_xorimm_correct: - forall n r, - let (op, args) := make_xorimm n r in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.xor e#r (Vint n)) v. -Proof. - intros; unfold make_xorimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. - subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.xor_zero; auto. - predSpec Int.eq Int.eq_spec n Int.mone; intros. - subst n. exists (Val.notint e#r); split; auto. - econstructor; split; eauto. auto. -Qed. - -Lemma make_addlimm_correct: - forall n r, - let (op, args) := make_addlimm n r in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.addl e#r (Vlong n)) v. -Proof. - intros. unfold make_addlimm. - predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. - subst. exists (e#r); split; auto. - destruct (e#r); simpl; auto. rewrite Int64.add_zero; auto. destruct Archi.ptr64; auto. rewrite 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. - destruct (e#r1); simpl; auto. - rewrite Int64.sub_add_opp; auto. - destruct Archi.ptr64 eqn:SF; auto. - rewrite Ptrofs.sub_add_opp. do 2 f_equal. auto with ptrofs. -(* mull *) - rewrite Val.mull_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_mullimm_correct; auto. - InvApproxRegs; SimplVM; inv H0. apply make_mullimm_correct; auto. -(* divl *) - assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto. - apply make_divlimm_correct; auto. -(* divlu *) - assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto. - apply make_divluimm_correct; auto. -(* modlu *) - assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto. - apply make_modluimm_correct; auto. -(* andl *) - rewrite Val.andl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_andlimm_correct; auto. - InvApproxRegs; SimplVM; inv H0. apply make_andlimm_correct; auto. - inv H; inv H0. apply make_andlimm_correct; auto. -(* orl *) - rewrite Val.orl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_orlimm_correct; auto. - InvApproxRegs; SimplVM; inv H0. apply make_orlimm_correct; auto. -(* xorl *) - rewrite Val.xorl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_xorlimm_correct; auto. - InvApproxRegs; SimplVM; inv H0. apply make_xorlimm_correct; auto. -(* shll *) - InvApproxRegs; SimplVM; inv H0. apply make_shllimm_correct; auto. -(* shrl *) - InvApproxRegs; SimplVM; inv H0. apply make_shrlimm_correct; auto. -(* shrlu *) - InvApproxRegs; SimplVM; inv H0. apply make_shrluimm_correct; auto. -(* leal *) - exploit addr_strength_reduction_64_correct; eauto. - destruct (addr_strength_reduction_64 addr args0 vl0) as [addr' args']. - auto. -(* cond *) - inv H0. apply make_cmp_correct; auto. -(* mulf *) - InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfimm_correct; auto. - InvApproxRegs; SimplVM; inv H0. fold (Val.mulf (Vfloat n1) e#r2). - rewrite <- H2. apply make_mulfimm_correct_2; auto. -(* mulfs *) - InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfsimm_correct; auto. - InvApproxRegs; SimplVM; inv H0. fold (Val.mulfs (Vsingle n1) e#r2). - rewrite <- H2. apply make_mulfsimm_correct_2; auto. -(* default *) - exists v; auto. -Qed. - -End STRENGTH_REDUCTION. diff --git a/ia32/Conventions1.v b/ia32/Conventions1.v deleted file mode 100644 index dbc8b064..00000000 --- a/ia32/Conventions1.v +++ /dev/null @@ -1,473 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Function calling conventions and other conventions regarding the use of - machine registers and stack slots. *) - -Require Import Coqlib Decidableplus. -Require Import AST Machregs Locations. - -(** * Classification of machine registers *) - -(** Machine registers (type [mreg] in module [Locations]) are divided in - the following groups: -- Callee-save registers, whose value is preserved across a function call. -- Caller-save registers that can be modified during a function call. - - We follow the x86-32 and x86-64 application binary interfaces (ABI) - in our choice of callee- and caller-save registers. -*) - -Definition is_callee_save (r: mreg) : bool := - match r with - | AX | CX | DX => false - | BX | BP => true - | SI | DI => negb Archi.ptr64 (**r callee-save in 32 bits but not in 64 bits *) - | R8 | R9 | R10 | R11 => false - | R12 | R13 | R14 | R15 => true - | X0 | X1 | X2 | X3 | X4 | X5 | X6 | X7 => false - | X8 | X9 | X10 | X11 | X12 | X13 | X14 | X15 => false - | FP0 => false - end. - -Definition int_caller_save_regs := - if Archi.ptr64 - then AX :: CX :: DX :: SI :: DI :: R8 :: R9 :: R10 :: R11 :: nil - else AX :: CX :: DX :: nil. - -Definition float_caller_save_regs := - if Archi.ptr64 - then X0 :: X1 :: X2 :: X3 :: X4 :: X5 :: X6 :: X7 :: - X8 :: X9 :: X10 :: X11 :: X12 :: X13 :: X14 :: X15 :: nil - else X0 :: X1 :: X2 :: X3 :: X4 :: X5 :: X6 :: X7 :: nil. - -Definition int_callee_save_regs := - if Archi.ptr64 - then BX :: BP :: R12 :: R13 :: R14 :: R15 :: nil - else BX :: SI :: DI :: BP :: nil. - -Definition float_callee_save_regs : list mreg := nil. - -Definition destroyed_at_call := - List.filter (fun r => negb (is_callee_save r)) all_mregs. - -Definition dummy_int_reg := AX. (**r Used in [Regalloc]. *) -Definition dummy_float_reg := X0. (**r Used in [Regalloc]. *) - -Definition is_float_reg (r: mreg) := - match r with - | AX | BX | CX | DX | SI | DI | BP - | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15 => false - | X0 | X1 | X2 | X3 | X4 | X5 | X6 | X7 - | X8 | X9 | X10 | X11 | X12 | X13 | X14 | X15 | FP0 => true - end. - -(** * Function calling conventions *) - -(** The functions in this section determine the locations (machine registers - and stack slots) used to communicate arguments and results between the - caller and the callee during function calls. These locations are functions - of the signature of the function and of the call instruction. - Agreement between the caller and the callee on the locations to use - is guaranteed by our dynamic semantics for Cminor and RTL, which demand - that the signature of the call instruction is identical to that of the - called function. - - Calling conventions are largely arbitrary: they must respect the properties - proved in this section (such as no overlapping between the locations - of function arguments), but this leaves much liberty in choosing actual - locations. To ensure binary interoperability of code generated by our - compiler with libraries compiled by another compiler, we - implement the standard x86-32 and x86-64 conventions. *) - -(** ** Location of function result *) - -(** In 32 bit mode, the result value of a function is passed back to the - caller in registers [AX] or [DX:AX] or [FP0], depending on the type - of the returned value. We treat a function without result as a - function with one integer result. *) - -Definition loc_result_32 (s: signature) : rpair mreg := - match s.(sig_res) with - | None => One AX - | Some (Tint | Tany32) => One AX - | Some (Tfloat | Tsingle) => One FP0 - | Some Tany64 => One X0 - | Some Tlong => Twolong DX AX - end. - -(** In 64 bit mode, he result value of a function is passed back to - the caller in registers [AX] or [X0]. *) - -Definition loc_result_64 (s: signature) : rpair mreg := - match s.(sig_res) with - | None => One AX - | Some (Tint | Tlong | Tany32 | Tany64) => One AX - | Some (Tfloat | Tsingle) => One X0 - end. - -Definition loc_result := - if Archi.ptr64 then loc_result_64 else loc_result_32. - -(** The result registers have types compatible with that given in the signature. *) - -Lemma loc_result_type: - forall sig, - subtype (proj_sig_res sig) (typ_rpair mreg_type (loc_result sig)) = true. -Proof. - intros. unfold proj_sig_res, loc_result, loc_result_32, loc_result_64, mreg_type; - destruct Archi.ptr64; destruct (sig_res sig) as [[]|]; auto. -Qed. - -(** The result locations are caller-save registers *) - -Lemma loc_result_caller_save: - forall (s: signature), - forall_rpair (fun r => is_callee_save r = false) (loc_result s). -Proof. - intros. unfold loc_result, loc_result_32, loc_result_64, is_callee_save; - destruct Archi.ptr64; destruct (sig_res s) as [[]|]; simpl; auto. -Qed. - -(** If the result is in a pair of registers, those registers are distinct and have type [Tint] at least. *) - -Lemma loc_result_pair: - forall sg, - match loc_result sg with - | One _ => True - | Twolong r1 r2 => - r1 <> r2 /\ sg.(sig_res) = Some Tlong - /\ subtype Tint (mreg_type r1) = true /\ subtype Tint (mreg_type r2) = true - /\ Archi.splitlong = true - end. -Proof. - intros. change Archi.splitlong with (negb Archi.ptr64). - unfold loc_result, loc_result_32, loc_result_64, mreg_type; - destruct Archi.ptr64; destruct (sig_res sg) as [[]|]; auto. - split; auto. congruence. -Qed. - -(** The location of the result depends only on the result part of the signature *) - -Lemma loc_result_exten: - forall s1 s2, s1.(sig_res) = s2.(sig_res) -> loc_result s1 = loc_result s2. -Proof. - intros. unfold loc_result, loc_result_32, loc_result_64. - destruct Archi.ptr64; rewrite H; auto. -Qed. - -(** ** Location of function arguments *) - -(** In the x86-32 ABI, all arguments are passed on stack. (Snif.) *) - -Fixpoint loc_arguments_32 - (tyl: list typ) (ofs: Z) {struct tyl} : list (rpair loc) := - match tyl with - | nil => nil - | ty :: tys => - match ty with - | Tlong => Twolong (S Outgoing (ofs + 1) Tint) (S Outgoing ofs Tint) - | _ => One (S Outgoing ofs ty) - end - :: loc_arguments_32 tys (ofs + typesize ty) - end. - -(** In the x86-64 ABI: -- The first 6 integer arguments are passed in registers [DI], [SI], [DX], [CX], [R8], [R9]. -- The first 8 floating-point arguments are passed in registers [X0] to [X7]. -- Extra arguments are passed on the stack, in [Outgoing] slots. - Consecutive stack slots are separated by 8 bytes, even if only 4 bytes - of data is used in a slot. -*) - -Definition int_param_regs := DI :: SI :: DX :: CX :: R8 :: R9 :: nil. -Definition float_param_regs := X0 :: X1 :: X2 :: X3 :: X4 :: X5 :: X6 :: X7 :: nil. - -Fixpoint loc_arguments_64 - (tyl: list typ) (ir fr ofs: Z) {struct tyl} : list (rpair loc) := - match tyl with - | nil => nil - | (Tint | Tlong | Tany32 | Tany64) as ty :: tys => - match list_nth_z int_param_regs ir with - | None => - One (S Outgoing ofs ty) :: loc_arguments_64 tys ir fr (ofs + 2) - | Some ireg => - One (R ireg) :: loc_arguments_64 tys (ir + 1) fr ofs - end - | (Tfloat | Tsingle) as ty :: tys => - match list_nth_z float_param_regs fr with - | None => - One (S Outgoing ofs ty) :: loc_arguments_64 tys ir fr (ofs + 2) - | Some freg => - One (R freg) :: loc_arguments_64 tys ir (fr + 1) ofs - end - end. - -(** [loc_arguments s] returns the list of locations where to store arguments - when calling a function with signature [s]. *) - -Definition loc_arguments (s: signature) : list (rpair loc) := - if Archi.ptr64 - then loc_arguments_64 s.(sig_args) 0 0 0 - else loc_arguments_32 s.(sig_args) 0. - -(** [size_arguments s] returns the number of [Outgoing] slots used - to call a function with signature [s]. *) - -Fixpoint size_arguments_32 - (tyl: list typ) (ofs: Z) {struct tyl} : Z := - match tyl with - | nil => ofs - | ty :: tys => size_arguments_32 tys (ofs + typesize ty) - end. - -Fixpoint size_arguments_64 (tyl: list typ) (ir fr ofs: Z) {struct tyl} : Z := - match tyl with - | nil => ofs - | (Tint | Tlong | Tany32 | Tany64) :: tys => - match list_nth_z int_param_regs ir with - | None => size_arguments_64 tys ir fr (ofs + 2) - | Some ireg => size_arguments_64 tys (ir + 1) fr ofs - end - | (Tfloat | Tsingle) :: tys => - match list_nth_z float_param_regs fr with - | None => size_arguments_64 tys ir fr (ofs + 2) - | Some freg => size_arguments_64 tys ir (fr + 1) ofs - end - end. - -Definition size_arguments (s: signature) : Z := - if Archi.ptr64 - then size_arguments_64 s.(sig_args) 0 0 0 - else size_arguments_32 s.(sig_args) 0. - -(** Argument locations are either caller-save registers or [Outgoing] - stack slots at nonnegative offsets. *) - -Definition loc_argument_acceptable (l: loc) : Prop := - match l with - | R r => is_callee_save r = false - | S Outgoing ofs ty => ofs >= 0 /\ (typealign ty | ofs) - | _ => False - end. - -Definition loc_argument_32_charact (ofs: Z) (l: loc) : Prop := - match l with - | S Outgoing ofs' ty => ofs' >= ofs /\ typealign ty = 1 - | _ => False - end. - -Definition loc_argument_64_charact (ofs: Z) (l: loc) : Prop := - match l with - | R r => In r int_param_regs \/ In r float_param_regs - | S Outgoing ofs' ty => ofs' >= ofs /\ (2 | ofs') - | _ => False - end. - -Remark loc_arguments_32_charact: - forall tyl ofs p, - In p (loc_arguments_32 tyl ofs) -> forall_rpair (loc_argument_32_charact ofs) p. -Proof. - assert (X: forall ofs1 ofs2 l, loc_argument_32_charact ofs2 l -> ofs1 <= ofs2 -> loc_argument_32_charact ofs1 l). - { destruct l; simpl; intros; auto. destruct sl; auto. intuition omega. } - induction tyl as [ | ty tyl]; simpl loc_arguments_32; intros. -- contradiction. -- destruct H. -+ destruct ty; subst p; simpl; omega. -+ apply IHtyl in H. generalize (typesize_pos ty); intros. destruct p; simpl in *. -* eapply X; eauto; omega. -* destruct H; split; eapply X; eauto; omega. -Qed. - -Remark loc_arguments_64_charact: - forall tyl ir fr ofs p, - In p (loc_arguments_64 tyl ir fr ofs) -> (2 | ofs) -> forall_rpair (loc_argument_64_charact ofs) p. -Proof. - assert (X: forall ofs1 ofs2 l, loc_argument_64_charact ofs2 l -> ofs1 <= ofs2 -> loc_argument_64_charact ofs1 l). - { destruct l; simpl; intros; auto. destruct sl; auto. intuition omega. } - assert (Y: forall ofs1 ofs2 p, forall_rpair (loc_argument_64_charact ofs2) p -> ofs1 <= ofs2 -> forall_rpair (loc_argument_64_charact ofs1) p). - { destruct p; simpl; intuition eauto. } - assert (Z: forall ofs, (2 | ofs) -> (2 | ofs + 2)). - { intros. apply Z.divide_add_r; auto. apply Zdivide_refl. } -Opaque list_nth_z. - induction tyl; simpl loc_arguments_64; intros. - elim H. - assert (A: forall ty, In p - match list_nth_z int_param_regs ir with - | Some ireg => One (R ireg) :: loc_arguments_64 tyl (ir + 1) fr ofs - | None => One (S Outgoing ofs ty) :: loc_arguments_64 tyl ir fr (ofs + 2) - end -> - forall_rpair (loc_argument_64_charact ofs) p). - { intros. destruct (list_nth_z int_param_regs ir) as [r|] eqn:E; destruct H1. - subst. left. eapply list_nth_z_in; eauto. - eapply IHtyl; eauto. - subst. split. omega. assumption. - eapply Y; eauto. omega. } - assert (B: forall ty, In p - match list_nth_z float_param_regs fr with - | Some ireg => One (R ireg) :: loc_arguments_64 tyl ir (fr + 1) ofs - | None => One (S Outgoing ofs ty) :: loc_arguments_64 tyl ir fr (ofs + 2) - end -> - forall_rpair (loc_argument_64_charact ofs) p). - { intros. destruct (list_nth_z float_param_regs fr) as [r|] eqn:E; destruct H1. - subst. right. eapply list_nth_z_in; eauto. - eapply IHtyl; eauto. - subst. split. omega. assumption. - eapply Y; eauto. omega. } - destruct a; eauto. -Qed. - -Lemma loc_arguments_acceptable: - forall (s: signature) (p: rpair loc), - In p (loc_arguments s) -> forall_rpair loc_argument_acceptable p. -Proof. - unfold loc_arguments; intros. destruct Archi.ptr64 eqn:SF. -- (* 64 bits *) - assert (A: forall r, In r int_param_regs -> is_callee_save r = false) by (unfold is_callee_save; rewrite SF; decide_goal). - assert (B: forall r, In r float_param_regs -> is_callee_save r = false) by decide_goal. - assert (X: forall l, loc_argument_64_charact 0 l -> loc_argument_acceptable l). - { unfold loc_argument_64_charact, loc_argument_acceptable. - destruct l as [r | [] ofs ty]; auto. intros [C|C]; auto. - intros [C D]. split; auto. apply Zdivide_trans with 2; auto. - exists (2 / typealign ty); destruct ty; reflexivity. - } - exploit loc_arguments_64_charact; eauto using Zdivide_0. - unfold forall_rpair; destruct p; intuition auto. -- (* 32 bits *) - assert (X: forall l, loc_argument_32_charact 0 l -> loc_argument_acceptable l). - { destruct l as [r | [] ofs ty]; simpl; intuition auto. rewrite H2; apply Z.divide_1_l. } - exploit loc_arguments_32_charact; eauto. - unfold forall_rpair; destruct p; intuition auto. -Qed. - -Hint Resolve loc_arguments_acceptable: locs. - -(** The offsets of [Outgoing] arguments are below [size_arguments s]. *) - -Remark size_arguments_32_above: - forall tyl ofs0, ofs0 <= size_arguments_32 tyl ofs0. -Proof. - induction tyl; simpl; intros. - omega. - apply Zle_trans with (ofs0 + typesize a); auto. - generalize (typesize_pos a); omega. -Qed. - -Remark size_arguments_64_above: - forall tyl ir fr ofs0, - ofs0 <= size_arguments_64 tyl ir fr ofs0. -Proof. - induction tyl; simpl; intros. - omega. - assert (A: ofs0 <= - match list_nth_z int_param_regs ir with - | Some _ => size_arguments_64 tyl (ir + 1) fr ofs0 - | None => size_arguments_64 tyl ir fr (ofs0 + 2) - end). - { destruct (list_nth_z int_param_regs ir); eauto. - apply Zle_trans with (ofs0 + 2); auto. omega. } - assert (B: ofs0 <= - match list_nth_z float_param_regs fr with - | Some _ => size_arguments_64 tyl ir (fr + 1) ofs0 - | None => size_arguments_64 tyl ir fr (ofs0 + 2) - end). - { destruct (list_nth_z float_param_regs fr); eauto. - apply Zle_trans with (ofs0 + 2); auto. omega. } - destruct a; auto. -Qed. - -Lemma size_arguments_above: - forall s, size_arguments s >= 0. -Proof. - intros; unfold size_arguments. apply Zle_ge. - destruct Archi.ptr64; [apply size_arguments_64_above|apply size_arguments_32_above]. -Qed. - -Lemma loc_arguments_32_bounded: - forall ofs ty tyl ofs0, - In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments_32 tyl ofs0)) -> - ofs + typesize ty <= size_arguments_32 tyl ofs0. -Proof. - induction tyl as [ | t l]; simpl; intros x IN. -- contradiction. -- rewrite in_app_iff in IN; destruct IN as [IN|IN]. -+ apply Zle_trans with (x + typesize t); [|apply size_arguments_32_above]. - Ltac decomp := - match goal with - | [ H: _ \/ _ |- _ ] => destruct H; decomp - | [ H: S _ _ _ = S _ _ _ |- _ ] => inv H - | [ H: False |- _ ] => contradiction - end. - destruct t; simpl in IN; decomp; simpl; omega. -+ apply IHl; auto. -Qed. - -Lemma loc_arguments_64_bounded: - forall ofs ty tyl ir fr ofs0, - In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments_64 tyl ir fr ofs0)) -> - ofs + typesize ty <= size_arguments_64 tyl ir fr ofs0. -Proof. - induction tyl; simpl; intros. - contradiction. - assert (T: forall ty0, typesize ty0 <= 2). - { destruct ty0; simpl; omega. } - assert (A: forall ty0, - In (S Outgoing ofs ty) (regs_of_rpairs - match list_nth_z int_param_regs ir with - | Some ireg => - One (R ireg) :: loc_arguments_64 tyl (ir + 1) fr ofs0 - | None => One (S Outgoing ofs0 ty0) :: loc_arguments_64 tyl ir fr (ofs0 + 2) - end) -> - ofs + typesize ty <= - match list_nth_z int_param_regs ir with - | Some _ => size_arguments_64 tyl (ir + 1) fr ofs0 - | None => size_arguments_64 tyl ir fr (ofs0 + 2) - end). - { intros. destruct (list_nth_z int_param_regs ir); simpl in H0; destruct H0. - - discriminate. - - eapply IHtyl; eauto. - - inv H0. apply Zle_trans with (ofs + 2). specialize (T ty). omega. apply size_arguments_64_above. - - eapply IHtyl; eauto. } - assert (B: forall ty0, - In (S Outgoing ofs ty) (regs_of_rpairs - match list_nth_z float_param_regs fr with - | Some ireg => - One (R ireg) :: loc_arguments_64 tyl ir (fr + 1) ofs0 - | None => One (S Outgoing ofs0 ty0) :: loc_arguments_64 tyl ir fr (ofs0 + 2) - end) -> - ofs + typesize ty <= - match list_nth_z float_param_regs fr with - | Some _ => size_arguments_64 tyl ir (fr + 1) ofs0 - | None => size_arguments_64 tyl ir fr (ofs0 + 2) - end). - { intros. destruct (list_nth_z float_param_regs fr); simpl in H0; destruct H0. - - discriminate. - - eapply IHtyl; eauto. - - inv H0. apply Zle_trans with (ofs + 2). specialize (T ty). omega. apply size_arguments_64_above. - - eapply IHtyl; eauto. } - destruct a; eauto. -Qed. - -Lemma loc_arguments_bounded: - forall (s: signature) (ofs: Z) (ty: typ), - In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments s)) -> - ofs + typesize ty <= size_arguments s. -Proof. - unfold loc_arguments, size_arguments; intros. - destruct Archi.ptr64; eauto using loc_arguments_32_bounded, loc_arguments_64_bounded. -Qed. - -Lemma loc_arguments_main: - loc_arguments signature_main = nil. -Proof. - unfold loc_arguments; destruct Archi.ptr64; reflexivity. -Qed. diff --git a/ia32/Machregs.v b/ia32/Machregs.v deleted file mode 100644 index 741081a6..00000000 --- a/ia32/Machregs.v +++ /dev/null @@ -1,367 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -Require Import String. -Require Import Coqlib. -Require Import Decidableplus. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Op. - -(** ** Machine registers *) - -(** The following type defines the machine registers that can be referenced - as locations. These include: -- Integer registers that can be allocated to RTL pseudo-registers. -- Floating-point registers that can be allocated to RTL pseudo-registers. -- The special [FP0] register denoting the top of the X87 float stack. - - The type [mreg] does not include special-purpose or reserved - machine registers such as the stack pointer and the condition codes. *) - -Inductive mreg: Type := - (** Allocatable integer regs *) - | AX | BX | CX | DX | SI | DI | BP - | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15 (**r only in 64-bit mode *) - (** Allocatable float regs *) - | X0 | X1 | X2 | X3 | X4 | X5 | X6 | X7 - | X8 | X9 | X10 | X11 | X12 | X13 | X14 | X15 (**r only in 64-bit mode *) - (** Special float reg *) - | FP0. - -Lemma mreg_eq: forall (r1 r2: mreg), {r1 = r2} + {r1 <> r2}. -Proof. decide equality. Defined. -Global Opaque mreg_eq. - -Definition all_mregs := - AX :: BX :: CX :: DX :: SI :: DI :: BP - :: R8 :: R9 :: R10 :: R11 :: R12 :: R13 :: R14 :: R15 - :: X0 :: X1 :: X2 :: X3 :: X4 :: X5 :: X6 :: X7 - :: X8 :: X9 :: X10 :: X11 :: X12 :: X13 :: X14 :: X15 - :: FP0 :: nil. - -Lemma all_mregs_complete: - forall (r: mreg), In r all_mregs. -Proof. - assert (forall r, proj_sumbool (In_dec mreg_eq r all_mregs) = true) by (destruct r; reflexivity). - intros. specialize (H r). InvBooleans. auto. -Qed. - -Instance Decidable_eq_mreg : forall (x y: mreg), Decidable (eq x y) := Decidable_eq mreg_eq. - -Instance Finite_mreg : Finite mreg := { - Finite_elements := all_mregs; - Finite_elements_spec := all_mregs_complete -}. - -Definition mreg_type (r: mreg): typ := - match r with - | AX | BX | CX | DX | SI | DI | BP => if Archi.ptr64 then Tany64 else Tany32 - | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15 => Tany64 - | X0 | X1 | X2 | X3 | X4 | X5 | X6 | X7 => Tany64 - | X8 | X9 | X10 | X11 | X12 | X13 | X14 | X15 => Tany64 - | FP0 => Tany64 - end. - -Local Open Scope positive_scope. - -Module IndexedMreg <: INDEXED_TYPE. - Definition t := mreg. - Definition eq := mreg_eq. - Definition index (r: mreg): positive := - match r with - | AX => 1 | BX => 2 | CX => 3 | DX => 4 | SI => 5 | DI => 6 | BP => 7 - | R8 => 8 | R9 => 9 | R10 => 10 | R11 => 11 | R12 => 12 | R13 => 13 | R14 => 14 | R15 => 15 - | X0 => 16 | X1 => 17 | X2 => 18 | X3 => 19 | X4 => 20 | X5 => 21 | X6 => 22 | X7 => 23 - | X8 => 24 | X9 => 25 | X10 => 26 | X11 => 27 | X12 => 28 | X13 => 29 | X14 => 30 | X15 => 31 - | FP0 => 32 - end. - Lemma index_inj: - forall r1 r2, index r1 = index r2 -> r1 = r2. - Proof. - decide_goal. - Qed. -End IndexedMreg. - -Definition is_stack_reg (r: mreg) : bool := - match r with FP0 => true | _ => false end. - -(** ** Names of registers *) - -Local Open Scope string_scope. - -Definition register_names := - ("RAX", AX) :: ("RBX", BX) :: ("RCX", CX) :: ("RDX", DX) :: - ("RSI", SI) :: ("RDI", DI) :: ("RBP", BP) :: - ("EAX", AX) :: ("EBX", BX) :: ("ECX", CX) :: ("EDX", DX) :: - ("ESI", SI) :: ("EDI", DI) :: ("EBP", BP) :: - ("R8", R8) :: ("R9", R9) :: ("R10", R10) :: ("R11", R11) :: - ("R12", R12) :: ("R13", R13) :: ("R14", R14) :: ("R15", R15) :: - ("XMM0", X0) :: ("XMM1", X1) :: ("XMM2", X2) :: ("XMM3", X3) :: - ("XMM4", X4) :: ("XMM5", X5) :: ("XMM6", X6) :: ("XMM7", X7) :: - ("XMM8", X8) :: ("XMM9", X9) :: ("XMM10", X10) :: ("XMM11", X11) :: - ("XMM12", X12) :: ("XMM13", X13) :: ("XMM14", X14) :: ("XMM15", X15) :: - ("ST0", FP0) :: nil. - -Definition register_by_name (s: string) : option mreg := - let fix assoc (l: list (string * mreg)) : option mreg := - match l with - | nil => None - | (s1, r1) :: l' => if string_dec s s1 then Some r1 else assoc l' - end - in assoc register_names. - -(** ** Destroyed registers, preferred registers *) - -Definition destroyed_by_op (op: operation): list mreg := - match op with - | Ocast8signed | Ocast8unsigned => AX :: nil - | Omulhs => AX :: DX :: nil - | Omulhu => AX :: DX :: nil - | Odiv => AX :: DX :: nil - | Odivu => AX :: DX :: nil - | Omod => AX :: DX :: nil - | Omodu => AX :: DX :: nil - | Oshrximm _ => CX :: nil - | Omullhs => AX :: DX :: nil - | Omullhu => AX :: DX :: nil - | Odivl => AX :: DX :: nil - | Odivlu => AX :: DX :: nil - | Omodl => AX :: DX :: nil - | Omodlu => AX :: DX :: nil - | Oshrxlimm _ => DX :: nil - | Ocmp _ => AX :: CX :: nil - | _ => nil - end. - -Definition destroyed_by_load (chunk: memory_chunk) (addr: addressing): list mreg := - nil. - -Definition destroyed_by_store (chunk: memory_chunk) (addr: addressing): list mreg := - match chunk with - | Mint8signed | Mint8unsigned => if Archi.ptr64 then nil else AX :: CX :: nil - | _ => nil - end. - -Definition destroyed_by_cond (cond: condition): list mreg := - nil. - -Definition destroyed_by_jumptable: list mreg := - AX :: DX :: nil. - -Fixpoint destroyed_by_clobber (cl: list string): list mreg := - match cl with - | nil => nil - | c1 :: cl => - match register_by_name c1 with - | Some r => r :: destroyed_by_clobber cl - | None => destroyed_by_clobber cl - end - end. - -Definition destroyed_by_builtin (ef: external_function): list mreg := - match ef with - | EF_memcpy sz al => - if zle sz 32 then CX :: X7 :: nil else CX :: SI :: DI :: nil - | EF_vstore (Mint8unsigned|Mint8signed) => - if Archi.ptr64 then nil else AX :: CX :: nil - | EF_builtin name sg => - if string_dec name "__builtin_va_start" then AX :: nil - else if string_dec name "__builtin_write16_reversed" - || string_dec name "__builtin_write32_reversed" - then CX :: DX :: nil - else nil - | EF_inline_asm txt sg clob => destroyed_by_clobber clob - | _ => nil - end. - -Definition destroyed_at_function_entry: list mreg := - (* must include [destroyed_by_setstack ty] *) - AX :: FP0 :: nil. - -Definition destroyed_by_setstack (ty: typ): list mreg := - match ty with - | Tfloat | Tsingle => FP0 :: nil - | _ => nil - end. - -Definition destroyed_at_indirect_call: list mreg := - nil. - -Definition temp_for_parent_frame: mreg := - AX. - -Definition mregs_for_operation (op: operation): list (option mreg) * option mreg := - match op with - | Omulhs => (Some AX :: None :: nil, Some DX) - | Omulhu => (Some AX :: None :: nil, Some DX) - | Odiv => (Some AX :: Some CX :: nil, Some AX) - | Odivu => (Some AX :: Some CX :: nil, Some AX) - | Omod => (Some AX :: Some CX :: nil, Some DX) - | Omodu => (Some AX :: Some CX :: nil, Some DX) - | Oshl => (None :: Some CX :: nil, None) - | Oshr => (None :: Some CX :: nil, None) - | Oshru => (None :: Some CX :: nil, None) - | Oshrximm _ => (Some AX :: nil, Some AX) - | Omullhs => (Some AX :: None :: nil, Some DX) - | Omullhu => (Some AX :: None :: nil, Some DX) - | Odivl => (Some AX :: Some CX :: nil, Some AX) - | Odivlu => (Some AX :: Some CX :: nil, Some AX) - | Omodl => (Some AX :: Some CX :: nil, Some DX) - | Omodlu => (Some AX :: Some CX :: nil, Some DX) - | Oshll => (None :: Some CX :: nil, None) - | Oshrl => (None :: Some CX :: nil, None) - | Oshrlu => (None :: Some CX :: nil, None) - | Oshrxlimm _ => (Some AX :: nil, Some AX) - | _ => (nil, None) - end. - -Definition mregs_for_builtin (ef: external_function): list (option mreg) * list (option mreg) := - match ef with - | EF_memcpy sz al => - if zle sz 32 then (Some AX :: Some DX :: nil, nil) else (Some DI :: Some SI :: nil, nil) - | EF_builtin name sg => - if string_dec name "__builtin_negl" then - (Some DX :: Some AX :: nil, Some DX :: Some AX :: nil) - else if string_dec name "__builtin_addl" - || string_dec name "__builtin_subl" then - (Some DX :: Some AX :: Some CX :: Some BX :: nil, Some DX :: Some AX :: nil) - else if string_dec name "__builtin_mull" then - (Some AX :: Some DX :: nil, Some DX :: Some AX :: nil) - else if string_dec name "__builtin_va_start" then - (Some DX :: nil, nil) - else if (negb Archi.ptr64) && string_dec name "__builtin_bswap64" then - (Some AX :: Some DX :: nil, Some DX :: Some AX :: nil) - else - (nil, nil) - | _ => (nil, nil) - end. - -Global Opaque - destroyed_by_op destroyed_by_load destroyed_by_store - destroyed_by_cond destroyed_by_jumptable destroyed_by_builtin - destroyed_by_setstack destroyed_at_function_entry temp_for_parent_frame - mregs_for_operation mregs_for_builtin. - -(** Two-address operations. Return [true] if the first argument and - the result must be in the same location *and* are unconstrained - by [mregs_for_operation]. *) - -Definition two_address_op (op: operation) : bool := - match op with - | Omove => false - | Ointconst _ => false - | Olongconst _ => false - | Ofloatconst _ => false - | Osingleconst _ => false - | Oindirectsymbol _ => false - | Ocast8signed => false - | Ocast8unsigned => false - | Ocast16signed => false - | Ocast16unsigned => false - | Oneg => true - | Osub => true - | Omul => true - | Omulimm _ => true - | Omulhs => false - | Omulhu => false - | Odiv => false - | Odivu => false - | Omod => false - | Omodu => false - | Oand => true - | Oandimm _ => true - | Oor => true - | Oorimm _ => true - | Oxor => true - | Oxorimm _ => true - | Onot => true - | Oshl => true - | Oshlimm _ => true - | Oshr => true - | Oshrimm _ => true - | Oshrximm _ => false - | Oshru => true - | Oshruimm _ => true - | Ororimm _ => true - | Oshldimm _ => true - | Olea addr => false - | Omakelong => true - | Olowlong => true - | Ohighlong => true - | Ocast32signed => false - | Ocast32unsigned => false - | Onegl => true - | Oaddlimm _ => true - | Osubl => true - | Omull => true - | Omullimm _ => true - | Omullhs => false - | Omullhu => false - | Odivl => false - | Odivlu => false - | Omodl => false - | Omodlu => false - | Oandl => true - | Oandlimm _ => true - | Oorl => true - | Oorlimm _ => true - | Oxorl => true - | Oxorlimm _ => true - | Onotl => true - | Oshll => true - | Oshllimm _ => true - | Oshrl => true - | Oshrlimm _ => true - | Oshrxlimm _ => false - | Oshrlu => true - | Oshrluimm _ => true - | Ororlimm _ => true - | Oleal addr => false - | Onegf => true - | Oabsf => true - | Oaddf => true - | Osubf => true - | Omulf => true - | Odivf => true - | Onegfs => true - | Oabsfs => true - | Oaddfs => true - | Osubfs => true - | Omulfs => true - | Odivfs => true - | Osingleoffloat => false - | Ofloatofsingle => false - | Ointoffloat => false - | Ofloatofint => false - | Ointofsingle => false - | Osingleofint => false - | Olongoffloat => false - | Ofloatoflong => false - | Olongofsingle => false - | Osingleoflong => false - | Ocmp c => false - end. - -(* Constraints on constant propagation for builtins *) - -Definition builtin_constraints (ef: external_function) : - list builtin_arg_constraint := - match ef with - | EF_vload _ => OK_addrany :: nil - | EF_vstore _ => OK_addrany :: OK_default :: nil - | EF_memcpy _ _ => OK_addrany :: OK_addrany :: nil - | EF_annot txt targs => map (fun _ => OK_all) targs - | EF_debug kind txt targs => map (fun _ => OK_all) targs - | _ => nil - end. diff --git a/ia32/Machregsaux.ml b/ia32/Machregsaux.ml deleted file mode 100644 index 473e0602..00000000 --- a/ia32/Machregsaux.ml +++ /dev/null @@ -1,33 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Auxiliary functions on machine registers *) - -open Camlcoq -open Machregs - -let register_names : (mreg, string) Hashtbl.t = Hashtbl.create 31 - -let _ = - List.iter - (fun (s, r) -> Hashtbl.add register_names r (camlstring_of_coqstring s)) - Machregs.register_names - -let is_scratch_register r = false - -let name_of_register r = - try Some (Hashtbl.find register_names r) with Not_found -> None - -let register_by_name s = - Machregs.register_by_name (coqstring_uppercase_ascii_of_camlstring s) - -let can_reserve_register r = Conventions1.is_callee_save r diff --git a/ia32/Machregsaux.mli b/ia32/Machregsaux.mli deleted file mode 100644 index 9404568d..00000000 --- a/ia32/Machregsaux.mli +++ /dev/null @@ -1,18 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Auxiliary functions on machine registers *) - -val name_of_register: Machregs.mreg -> string option -val register_by_name: string -> Machregs.mreg option -val is_scratch_register: string -> bool -val can_reserve_register: Machregs.mreg -> bool diff --git a/ia32/NeedOp.v b/ia32/NeedOp.v deleted file mode 100644 index 09013cdd..00000000 --- a/ia32/NeedOp.v +++ /dev/null @@ -1,254 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Neededness analysis for x86_64 operators *) - -Require Import Coqlib. -Require Import AST Integers Floats Values Memory Globalenvs. -Require Import Op NeedDomain RTL. - -Definition op1 (nv: nval) := nv :: nil. -Definition op2 (nv: nval) := nv :: nv :: nil. - -Definition needs_of_condition (cond: condition): list nval := - match cond with - | Cmaskzero n | Cmasknotzero n => op1 (maskzero n) - | _ => nil - end. - -Definition needs_of_addressing_32 (addr: addressing) (nv: nval): list nval := - match addr with - | Aindexed n => op1 (modarith nv) - | Aindexed2 n => op2 (modarith nv) - | Ascaled sc ofs => op1 (modarith (modarith nv)) - | Aindexed2scaled sc ofs => op2 (modarith nv) - | Aglobal s ofs => nil - | Abased s ofs => op1 (modarith nv) - | Abasedscaled sc s ofs => op1 (modarith (modarith nv)) - | Ainstack ofs => nil - end. - -Definition needs_of_addressing_64 (addr: addressing) (nv: nval): list nval := - match addr with - | Aindexed n => op1 (default nv) - | Aindexed2 n => op2 (default nv) - | Ascaled sc ofs => op1 (default nv) - | Aindexed2scaled sc ofs => op2 (default nv) - | Aglobal s ofs => nil - | Abased s ofs => op1 (default nv) - | Abasedscaled sc s ofs => op1 (default nv) - | Ainstack ofs => nil - end. - -Definition needs_of_addressing (addr: addressing) (nv: nval): list nval := - if Archi.ptr64 then needs_of_addressing_64 addr nv else needs_of_addressing_32 addr nv. - -Definition needs_of_operation (op: operation) (nv: nval): list nval := - match op with - | Omove => op1 nv - | Ointconst n => nil - | Olongconst n => nil - | Ofloatconst n => nil - | Osingleconst n => nil - | Oindirectsymbol id => nil - | Ocast8signed => op1 (sign_ext 8 nv) - | Ocast8unsigned => op1 (zero_ext 8 nv) - | Ocast16signed => op1 (sign_ext 16 nv) - | Ocast16unsigned => op1 (zero_ext 16 nv) - | Oneg => op1 (modarith nv) - | Osub => op2 (default nv) - | Omul => op2 (modarith nv) - | Omulimm n => op1 (modarith nv) - | Omulhs | Omulhu | Odiv | Odivu | Omod | Omodu => op2 (default nv) - | Oand => op2 (bitwise nv) - | Oandimm n => op1 (andimm nv n) - | Oor => op2 (bitwise nv) - | Oorimm n => op1 (orimm nv n) - | Oxor => op2 (bitwise nv) - | Oxorimm n => op1 (bitwise nv) - | Onot => op1 (bitwise nv) - | Oshl => op2 (default nv) - | Oshlimm n => op1 (shlimm nv n) - | Oshr => op2 (default nv) - | Oshrimm n => op1 (shrimm nv n) - | Oshrximm n => op1 (default nv) - | Oshru => op2 (default nv) - | Oshruimm n => op1 (shruimm nv n) - | Ororimm n => op1 (ror nv n) - | Oshldimm n => op1 (default nv) - | Olea addr => needs_of_addressing_32 addr nv - | Omakelong => op2 (default nv) - | Olowlong | Ohighlong => op1 (default nv) - | Ocast32signed => op1 (default nv) - | Ocast32unsigned => op1 (default nv) - | Onegl => op1 (default nv) - | Oaddlimm _ => op1 (default nv) - | Osubl => op2 (default nv) - | Omull => op2 (default nv) - | Omullimm _ => op1 (default nv) - | Omullhs | Omullhu | Odivl | Odivlu | Omodl | Omodlu => op2 (default nv) - | Oandl => op2 (default nv) - | Oandlimm _ => op1 (default nv) - | Oorl => op2 (default nv) - | Oorlimm _ => op1 (default nv) - | Oxorl => op2 (default nv) - | Oxorlimm _ => op1 (default nv) - | Onotl => op1 (default nv) - | Oshll => op2 (default nv) - | Oshllimm _ => op1 (default nv) - | Oshrl => op2 (default nv) - | Oshrlimm _ => op1 (default nv) - | Oshrxlimm n => op1 (default nv) - | Oshrlu => op2 (default nv) - | Oshrluimm _ => op1 (default nv) - | Ororlimm _ => op1 (default nv) - | Oleal addr => needs_of_addressing_64 addr nv - | Onegf | Oabsf => op1 (default nv) - | Oaddf | Osubf | Omulf | Odivf => op2 (default nv) - | Onegfs | Oabsfs => op1 (default nv) - | Oaddfs | Osubfs | Omulfs | Odivfs => op2 (default nv) - | Osingleoffloat | Ofloatofsingle => op1 (default nv) - | Ointoffloat | Ofloatofint | Ointofsingle | Osingleofint => op1 (default nv) - | Olongoffloat | Ofloatoflong | Olongofsingle | Osingleoflong => op1 (default nv) - | Ocmp c => needs_of_condition c - end. - -Definition operation_is_redundant (op: operation) (nv: nval): bool := - match op with - | Ocast8signed => sign_ext_redundant 8 nv - | Ocast8unsigned => zero_ext_redundant 8 nv - | Ocast16signed => sign_ext_redundant 16 nv - | Ocast16unsigned => zero_ext_redundant 16 nv - | Oandimm n => andimm_redundant nv n - | Oorimm n => orimm_redundant nv n - | _ => false - end. - -Ltac InvAgree := - match goal with - | [H: vagree_list nil _ _ |- _ ] => inv H; InvAgree - | [H: vagree_list (_::_) _ _ |- _ ] => inv H; InvAgree - | _ => idtac - end. - -Ltac TrivialExists := - match goal with - | [ |- exists v, Some ?x = Some v /\ _ ] => exists x; split; auto - | _ => idtac - end. - -Section SOUNDNESS. - -Variable ge: genv. -Variable sp: block. -Variables m m': mem. -Hypothesis PERM: forall b ofs k p, Mem.perm m b ofs k p -> Mem.perm m' b ofs k p. - -Lemma needs_of_condition_sound: - forall cond args b args', - eval_condition cond args m = Some b -> - vagree_list args args' (needs_of_condition cond) -> - eval_condition cond args' m' = Some b. -Proof. - intros. destruct cond; simpl in H; - try (eapply default_needs_of_condition_sound; eauto; fail); - simpl in *; FuncInv; InvAgree. -- eapply maskzero_sound; eauto. -- destruct (Val.maskzero_bool v n) as [b'|] eqn:MZ; try discriminate. - erewrite maskzero_sound; eauto. -Qed. - -Lemma needs_of_addressing_32_sound: - forall sp addr args v nv args', - eval_addressing32 ge (Vptr sp Ptrofs.zero) addr args = Some v -> - vagree_list args args' (needs_of_addressing_32 addr nv) -> - exists v', - eval_addressing32 ge (Vptr sp Ptrofs.zero) addr args' = Some v' - /\ vagree v v' nv. -Proof. - unfold needs_of_addressing_32; intros. - destruct addr; simpl in *; FuncInv; InvAgree; TrivialExists; - auto using add_sound, mul_sound with na. - apply add_sound; auto with na. apply add_sound; rewrite modarith_idem; auto. - apply add_sound; auto. apply add_sound; rewrite modarith_idem; auto with na. - apply mul_sound; rewrite modarith_idem; auto with na. -Qed. - -(* -Lemma needs_of_addressing_64_sound: - forall sp addr args v nv args', - eval_addressing64 ge (Vptr sp Ptrofs.zero) addr args = Some v -> - vagree_list args args' (needs_of_addressing_64 addr nv) -> - exists v', - eval_addressing64 ge (Vptr sp Ptrofs.zero) addr args' = Some v' - /\ vagree v v' nv. -*) - -Lemma needs_of_operation_sound: - forall op args v nv args', - eval_operation ge (Vptr sp Ptrofs.zero) op args m = Some v -> - vagree_list args args' (needs_of_operation op nv) -> - nv <> Nothing -> - exists v', - eval_operation ge (Vptr sp Ptrofs.zero) op args' m' = Some v' - /\ vagree v v' nv. -Proof. - unfold needs_of_operation; intros; destruct op; try (eapply default_needs_of_operation_sound; eauto; fail); - simpl in *; FuncInv; InvAgree; TrivialExists. -- apply sign_ext_sound; auto. compute; auto. -- apply zero_ext_sound; auto. omega. -- apply sign_ext_sound; auto. compute; auto. -- apply zero_ext_sound; auto. omega. -- apply neg_sound; auto. -- apply mul_sound; auto. -- apply mul_sound; auto with na. -- apply and_sound; auto. -- apply andimm_sound; auto. -- apply or_sound; auto. -- apply orimm_sound; auto. -- apply xor_sound; auto. -- apply xor_sound; auto with na. -- apply notint_sound; auto. -- apply shlimm_sound; auto. -- apply shrimm_sound; auto. -- apply shruimm_sound; auto. -- apply ror_sound; auto. -- eapply needs_of_addressing_32_sound; eauto. -- change (eval_addressing64 ge (Vptr sp Ptrofs.zero) a args') - with (eval_operation ge (Vptr sp Ptrofs.zero) (Oleal a) args' m'). - eapply default_needs_of_operation_sound; eauto. - destruct a; simpl in H0; auto. -- destruct (eval_condition cond args m) as [b|] eqn:EC; simpl in H2. - erewrite needs_of_condition_sound by eauto. - subst v; simpl. auto with na. - subst v; auto with na. -Qed. - -Lemma operation_is_redundant_sound: - forall op nv arg1 args v arg1' args', - operation_is_redundant op nv = true -> - eval_operation ge (Vptr sp Ptrofs.zero) op (arg1 :: args) m = Some v -> - vagree_list (arg1 :: args) (arg1' :: args') (needs_of_operation op nv) -> - vagree v arg1' nv. -Proof. - intros. destruct op; simpl in *; try discriminate; inv H1; FuncInv; subst. -- apply sign_ext_redundant_sound; auto. omega. -- apply zero_ext_redundant_sound; auto. omega. -- apply sign_ext_redundant_sound; auto. omega. -- apply zero_ext_redundant_sound; auto. omega. -- apply andimm_redundant_sound; auto. -- apply orimm_redundant_sound; auto. -Qed. - -End SOUNDNESS. - - diff --git a/ia32/Op.v b/ia32/Op.v deleted file mode 100644 index eb2fd110..00000000 --- a/ia32/Op.v +++ /dev/null @@ -1,1457 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Operators and addressing modes. The abstract syntax and dynamic - semantics for the CminorSel, RTL, LTL and Mach languages depend on the - following types, defined in this library: -- [condition]: boolean conditions for conditional branches; -- [operation]: arithmetic and logical operations; -- [addressing]: addressing modes for load and store operations. - - These types are X86-64-specific and correspond roughly to what the - processor can compute in one instruction. In other terms, these - types reflect the state of the program after instruction selection. - For a processor-independent set of operations, see the abstract - syntax and dynamic semantics of the Cminor language. -*) - -Require Import Coqlib. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Events. - -Set Implicit Arguments. - -(** Conditions (boolean-valued operators). *) - -Inductive condition : Type := - | Ccomp (c: comparison) (**r signed integer comparison *) - | Ccompu (c: comparison) (**r unsigned integer comparison *) - | Ccompimm (c: comparison) (n: int) (**r signed integer comparison with a constant *) - | Ccompuimm (c: comparison) (n: int) (**r unsigned integer comparison with a constant *) - | Ccompl (c: comparison) (**r signed 64-bit integer comparison *) - | Ccomplu (c: comparison) (**r unsigned 64-bit integer comparison *) - | Ccomplimm (c: comparison) (n: int64) (**r signed 64-bit integer comparison with a constant *) - | Ccompluimm (c: comparison) (n: int64) (**r unsigned 64-bit integer comparison with a constant *) - | Ccompf (c: comparison) (**r 64-bit floating-point comparison *) - | Cnotcompf (c: comparison) (**r negation of a floating-point comparison *) - | Ccompfs (c: comparison) (**r 32-bit floating-point comparison *) - | Cnotcompfs (c: comparison) (**r negation of a floating-point comparison *) - | Cmaskzero (n: int) (**r test [(arg & constant) == 0] *) - | Cmasknotzero (n: int). (**r test [(arg & constant) != 0] *) - -(** Addressing modes. [r1], [r2], etc, are the arguments to the - addressing. *) - -Inductive addressing: Type := - | Aindexed: Z -> addressing (**r Address is [r1 + offset] *) - | Aindexed2: Z -> addressing (**r Address is [r1 + r2 + offset] *) - | Ascaled: Z -> Z -> addressing (**r Address is [r1 * scale + offset] *) - | Aindexed2scaled: Z -> Z -> addressing - (**r Address is [r1 + r2 * scale + offset] *) - | Aglobal: ident -> ptrofs -> addressing (**r Address is [symbol + offset] *) - | Abased: ident -> ptrofs -> addressing (**r Address is [symbol + offset + r1] *) - | Abasedscaled: Z -> ident -> ptrofs -> addressing (**r Address is [symbol + offset + r1 * scale] *) - | Ainstack: ptrofs -> addressing. (**r Address is [stack_pointer + offset] *) - -(** Arithmetic and logical operations. In the descriptions, [rd] is the - result of the operation and [r1], [r2], etc, are the arguments. *) - -Inductive operation : Type := - | Omove (**r [rd = r1] *) - | Ointconst (n: int) (**r [rd] is set to the given integer constant *) - | Olongconst (n: int64) (**r [rd] is set to the given integer constant *) - | Ofloatconst (n: float) (**r [rd] is set to the given float constant *) - | Osingleconst (n: float32)(**r [rd] is set to the given float constant *) - | Oindirectsymbol (id: ident) (**r [rd] is set to the address of the symbol *) -(*c 32-bit integer arithmetic: *) - | Ocast8signed (**r [rd] is 8-bit sign extension of [r1] *) - | Ocast8unsigned (**r [rd] is 8-bit zero extension of [r1] *) - | Ocast16signed (**r [rd] is 16-bit sign extension of [r1] *) - | Ocast16unsigned (**r [rd] is 16-bit zero extension of [r1] *) - | Oneg (**r [rd = - r1] *) - | Osub (**r [rd = r1 - r2] *) - | Omul (**r [rd = r1 * r2] *) - | Omulimm (n: int) (**r [rd = r1 * n] *) - | Omulhs (**r [rd = high part of r1 * r2, signed] *) - | Omulhu (**r [rd = high part of r1 * r2, unsigned] *) - | Odiv (**r [rd = r1 / r2] (signed) *) - | Odivu (**r [rd = r1 / r2] (unsigned) *) - | Omod (**r [rd = r1 % r2] (signed) *) - | Omodu (**r [rd = r1 % r2] (unsigned) *) - | Oand (**r [rd = r1 & r2] *) - | Oandimm (n: int) (**r [rd = r1 & n] *) - | Oor (**r [rd = r1 | r2] *) - | Oorimm (n: int) (**r [rd = r1 | n] *) - | Oxor (**r [rd = r1 ^ r2] *) - | Oxorimm (n: int) (**r [rd = r1 ^ n] *) - | Onot (**r [rd = ~r1] *) - | Oshl (**r [rd = r1 << r2] *) - | Oshlimm (n: int) (**r [rd = r1 << n] *) - | Oshr (**r [rd = r1 >> r2] (signed) *) - | Oshrimm (n: int) (**r [rd = r1 >> n] (signed) *) - | Oshrximm (n: int) (**r [rd = r1 / 2^n] (signed) *) - | Oshru (**r [rd = r1 >> r2] (unsigned) *) - | Oshruimm (n: int) (**r [rd = r1 >> n] (unsigned) *) - | Ororimm (n: int) (**r rotate right immediate *) - | Oshldimm (n: int) (**r [rd = r1 << n | r2 >> (32-n)] *) - | Olea (a: addressing) (**r effective address *) -(*c 64-bit integer arithmetic: *) - | Omakelong (**r [rd = r1 << 32 | r2] *) - | Olowlong (**r [rd = low-word(r1)] *) - | Ohighlong (**r [rd = high-word(r1)] *) - | Ocast32signed (**r [rd] is 32-bit sign extension of [r1] *) - | Ocast32unsigned (**r [rd] is 32-bit zero extension of [r1] *) - | Onegl (**r [rd = - r1] *) - | Oaddlimm (n: int64) (**r [rd = r1 + n] *) - | Osubl (**r [rd = r1 - r2] *) - | Omull (**r [rd = r1 * r2] *) - | Omullimm (n: int64) (**r [rd = r1 * n] *) - | Omullhs (**r [rd = high part of r1 * r2, signed] *) - | Omullhu (**r [rd = high part of r1 * r2, unsigned] *) - | Odivl (**r [rd = r1 / r2] (signed) *) - | Odivlu (**r [rd = r1 / r2] (unsigned) *) - | Omodl (**r [rd = r1 % r2] (signed) *) - | Omodlu (**r [rd = r1 % r2] (unsigned) *) - | Oandl (**r [rd = r1 & r2] *) - | Oandlimm (n: int64) (**r [rd = r1 & n] *) - | Oorl (**r [rd = r1 | r2] *) - | Oorlimm (n: int64) (**r [rd = r1 | n] *) - | Oxorl (**r [rd = r1 ^ r2] *) - | Oxorlimm (n: int64) (**r [rd = r1 ^ n] *) - | Onotl (**r [rd = ~r1] *) - | Oshll (**r [rd = r1 << r2] *) - | Oshllimm (n: int) (**r [rd = r1 << n] *) - | Oshrl (**r [rd = r1 >> r2] (signed) *) - | Oshrlimm (n: int) (**r [rd = r1 >> n] (signed) *) - | Oshrxlimm (n: int) (**r [rd = r1 / 2^n] (signed) *) - | Oshrlu (**r [rd = r1 >> r2] (unsigned) *) - | Oshrluimm (n: int) (**r [rd = r1 >> n] (unsigned) *) - | Ororlimm (n: int) (**r rotate right immediate *) - | Oleal (a: addressing) (**r effective address *) -(*c Floating-point arithmetic: *) - | Onegf (**r [rd = - r1] *) - | Oabsf (**r [rd = abs(r1)] *) - | Oaddf (**r [rd = r1 + r2] *) - | Osubf (**r [rd = r1 - r2] *) - | Omulf (**r [rd = r1 * r2] *) - | Odivf (**r [rd = r1 / r2] *) - | Onegfs (**r [rd = - r1] *) - | Oabsfs (**r [rd = abs(r1)] *) - | Oaddfs (**r [rd = r1 + r2] *) - | Osubfs (**r [rd = r1 - r2] *) - | Omulfs (**r [rd = r1 * r2] *) - | Odivfs (**r [rd = r1 / r2] *) - | Osingleoffloat (**r [rd] is [r1] truncated to single-precision float *) - | Ofloatofsingle (**r [rd] is [r1] extended to double-precision float *) -(*c Conversions between int and float: *) - | Ointoffloat (**r [rd = signed_int_of_float64(r1)] *) - | Ofloatofint (**r [rd = float64_of_signed_int(r1)] *) - | Ointofsingle (**r [rd = signed_int_of_float32(r1)] *) - | Osingleofint (**r [rd = float32_of_signed_int(r1)] *) - | Olongoffloat (**r [rd = signed_long_of_float64(r1)] *) - | Ofloatoflong (**r [rd = float64_of_signed_long(r1)] *) - | Olongofsingle (**r [rd = signed_long_of_float32(r1)] *) - | Osingleoflong (**r [rd = float32_of_signed_long(r1)] *) -(*c Boolean tests: *) - | Ocmp (cond: condition). (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) - -(** Comparison functions (used in modules [CSE] and [Allocation]). *) - -Definition eq_condition (x y: condition) : {x=y} + {x<>y}. -Proof. - generalize Int.eq_dec Int64.eq_dec; intro. - assert (forall (x y: comparison), {x=y}+{x<>y}). decide equality. - decide equality. -Defined. - -Definition eq_addressing (x y: addressing) : {x=y} + {x<>y}. -Proof. - generalize ident_eq Ptrofs.eq_dec zeq; intros. - decide equality. -Defined. - -Definition eq_operation (x y: operation): {x=y} + {x<>y}. -Proof. - generalize Int.eq_dec Int64.eq_dec Float.eq_dec Float32.eq_dec; intros. - decide equality. - apply ident_eq. - apply eq_addressing. - apply eq_addressing. - apply eq_condition. -Defined. - -Global Opaque eq_condition eq_addressing eq_operation. - -(** In addressing modes, offsets are 32-bit signed integers, even in 64-bit mode. - The following function checks that an addressing mode is valid, i.e. that - the offsets are in range. *) - -Definition offset_in_range (n: Z) : bool := zle Int.min_signed n && zle n Int.max_signed. - -Definition addressing_valid (a: addressing) : bool := - match a with - | Aindexed n => offset_in_range n - | Aindexed2 n => offset_in_range n - | Ascaled sc ofs => offset_in_range ofs - | Aindexed2scaled sc ofs => offset_in_range ofs - | Aglobal s ofs => true - | Abased s ofs => true - | Abasedscaled sc s ofs => true - | Ainstack ofs => offset_in_range (Ptrofs.signed ofs) - end. - -(** * Evaluation functions *) - -(** Evaluation of conditions, operators and addressing modes applied - to lists of values. Return [None] when the computation can trigger an - error, e.g. integer division by zero. [eval_condition] returns a boolean, - [eval_operation] and [eval_addressing] return a value. *) - -Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool := - match cond, vl with - | Ccomp c, v1 :: v2 :: nil => Val.cmp_bool c v1 v2 - | Ccompu c, v1 :: v2 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 v2 - | Ccompimm c n, v1 :: nil => Val.cmp_bool c v1 (Vint n) - | Ccompuimm c n, v1 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 (Vint n) - | Ccompl c, v1 :: v2 :: nil => Val.cmpl_bool c v1 v2 - | Ccomplu c, v1 :: v2 :: nil => Val.cmplu_bool (Mem.valid_pointer m) c v1 v2 - | Ccomplimm c n, v1 :: nil => Val.cmpl_bool c v1 (Vlong n) - | Ccompluimm c n, v1 :: nil => Val.cmplu_bool (Mem.valid_pointer m) c v1 (Vlong n) - | Ccompf c, v1 :: v2 :: nil => Val.cmpf_bool c v1 v2 - | Cnotcompf c, v1 :: v2 :: nil => option_map negb (Val.cmpf_bool c v1 v2) - | Ccompfs c, v1 :: v2 :: nil => Val.cmpfs_bool c v1 v2 - | Cnotcompfs c, v1 :: v2 :: nil => option_map negb (Val.cmpfs_bool c v1 v2) - | Cmaskzero n, v1 :: nil => Val.maskzero_bool v1 n - | Cmasknotzero n, v1 :: nil => option_map negb (Val.maskzero_bool v1 n) - | _, _ => None - end. - -Definition eval_addressing32 - (F V: Type) (genv: Genv.t F V) (sp: val) - (addr: addressing) (vl: list val) : option val := - match addr, vl with - | Aindexed n, v1::nil => - Some (Val.add v1 (Vint (Int.repr n))) - | Aindexed2 n, v1::v2::nil => - Some (Val.add (Val.add v1 v2) (Vint (Int.repr n))) - | Ascaled sc ofs, v1::nil => - Some (Val.add (Val.mul v1 (Vint (Int.repr sc))) (Vint (Int.repr ofs))) - | Aindexed2scaled sc ofs, v1::v2::nil => - Some(Val.add v1 (Val.add (Val.mul v2 (Vint (Int.repr sc))) (Vint (Int.repr ofs)))) - | Aglobal s ofs, nil => - if Archi.ptr64 then None else Some (Genv.symbol_address genv s ofs) - | Abased s ofs, v1::nil => - if Archi.ptr64 then None else Some (Val.add (Genv.symbol_address genv s ofs) v1) - | Abasedscaled sc s ofs, v1::nil => - if Archi.ptr64 then None else Some (Val.add (Genv.symbol_address genv s ofs) (Val.mul v1 (Vint (Int.repr sc)))) - | Ainstack ofs, nil => - if Archi.ptr64 then None else Some(Val.offset_ptr sp ofs) - | _, _ => None - end. - -Definition eval_addressing64 - (F V: Type) (genv: Genv.t F V) (sp: val) - (addr: addressing) (vl: list val) : option val := - match addr, vl with - | Aindexed n, v1::nil => - Some (Val.addl v1 (Vlong (Int64.repr n))) - | Aindexed2 n, v1::v2::nil => - Some (Val.addl (Val.addl v1 v2) (Vlong (Int64.repr n))) - | Ascaled sc ofs, v1::nil => - Some (Val.addl (Val.mull v1 (Vlong (Int64.repr sc))) (Vlong (Int64.repr ofs))) - | Aindexed2scaled sc ofs, v1::v2::nil => - Some(Val.addl v1 (Val.addl (Val.mull v2 (Vlong (Int64.repr sc))) (Vlong (Int64.repr ofs)))) - | Aglobal s ofs, nil => - if Archi.ptr64 then Some (Genv.symbol_address genv s ofs) else None - | Ainstack ofs, nil => - if Archi.ptr64 then Some(Val.offset_ptr sp ofs) else None - | _, _ => None - end. - -Definition eval_addressing - (F V: Type) (genv: Genv.t F V) (sp: val) - (addr: addressing) (vl: list val) : option val := - if Archi.ptr64 - then eval_addressing64 genv sp addr vl - else eval_addressing32 genv sp addr vl. - -Definition eval_operation - (F V: Type) (genv: Genv.t F V) (sp: val) - (op: operation) (vl: list val) (m: mem): option val := - match op, vl with - | Omove, v1::nil => Some v1 - | Ointconst n, nil => Some (Vint n) - | Olongconst n, nil => Some (Vlong n) - | Ofloatconst n, nil => Some (Vfloat n) - | Osingleconst n, nil => Some (Vsingle n) - | Oindirectsymbol id, nil => Some (Genv.symbol_address genv id Ptrofs.zero) - | Ocast8signed, v1 :: nil => Some (Val.sign_ext 8 v1) - | Ocast8unsigned, v1 :: nil => Some (Val.zero_ext 8 v1) - | Ocast16signed, v1 :: nil => Some (Val.sign_ext 16 v1) - | Ocast16unsigned, v1 :: nil => Some (Val.zero_ext 16 v1) - | Oneg, v1::nil => Some (Val.neg v1) - | Osub, v1::v2::nil => Some (Val.sub v1 v2) - | Omul, v1::v2::nil => Some (Val.mul v1 v2) - | Omulimm n, v1::nil => Some (Val.mul v1 (Vint n)) - | Omulhs, v1::v2::nil => Some (Val.mulhs v1 v2) - | Omulhu, v1::v2::nil => Some (Val.mulhu v1 v2) - | Odiv, v1::v2::nil => Val.divs v1 v2 - | Odivu, v1::v2::nil => Val.divu v1 v2 - | Omod, v1::v2::nil => Val.mods v1 v2 - | Omodu, v1::v2::nil => Val.modu v1 v2 - | Oand, v1::v2::nil => Some(Val.and v1 v2) - | Oandimm n, v1::nil => Some (Val.and v1 (Vint n)) - | Oor, v1::v2::nil => Some(Val.or v1 v2) - | Oorimm n, v1::nil => Some (Val.or v1 (Vint n)) - | Oxor, v1::v2::nil => Some(Val.xor v1 v2) - | Oxorimm n, v1::nil => Some (Val.xor v1 (Vint n)) - | Onot, v1::nil => Some(Val.notint v1) - | Oshl, v1::v2::nil => Some (Val.shl v1 v2) - | Oshlimm n, v1::nil => Some (Val.shl v1 (Vint n)) - | Oshr, v1::v2::nil => Some (Val.shr v1 v2) - | Oshrimm n, v1::nil => Some (Val.shr v1 (Vint n)) - | Oshrximm n, v1::nil => Val.shrx v1 (Vint n) - | Oshru, v1::v2::nil => Some (Val.shru v1 v2) - | Oshruimm n, v1::nil => Some (Val.shru v1 (Vint n)) - | Ororimm n, v1::nil => Some (Val.ror v1 (Vint n)) - | Oshldimm n, v1::v2::nil => Some (Val.or (Val.shl v1 (Vint n)) - (Val.shru v2 (Vint (Int.sub Int.iwordsize n)))) - | Olea addr, _ => eval_addressing32 genv sp addr vl - | Omakelong, v1::v2::nil => Some(Val.longofwords v1 v2) - | Olowlong, v1::nil => Some(Val.loword v1) - | Ohighlong, v1::nil => Some(Val.hiword v1) - | Ocast32signed, v1 :: nil => Some (Val.longofint v1) - | Ocast32unsigned, v1 :: nil => Some (Val.longofintu v1) - | Onegl, v1::nil => Some (Val.negl v1) - | Oaddlimm n, v1::nil => Some (Val.addl v1 (Vlong n)) - | Osubl, v1::v2::nil => Some (Val.subl v1 v2) - | Omull, v1::v2::nil => Some (Val.mull v1 v2) - | Omullimm n, v1::nil => Some (Val.mull v1 (Vlong n)) - | Omullhs, v1::v2::nil => Some (Val.mullhs v1 v2) - | Omullhu, v1::v2::nil => Some (Val.mullhu v1 v2) - | Odivl, v1::v2::nil => Val.divls v1 v2 - | Odivlu, v1::v2::nil => Val.divlu v1 v2 - | Omodl, v1::v2::nil => Val.modls v1 v2 - | Omodlu, v1::v2::nil => Val.modlu v1 v2 - | Oandl, v1::v2::nil => Some(Val.andl v1 v2) - | Oandlimm n, v1::nil => Some (Val.andl v1 (Vlong n)) - | Oorl, v1::v2::nil => Some(Val.orl v1 v2) - | Oorlimm n, v1::nil => Some (Val.orl v1 (Vlong n)) - | Oxorl, v1::v2::nil => Some(Val.xorl v1 v2) - | Oxorlimm n, v1::nil => Some (Val.xorl v1 (Vlong n)) - | Onotl, v1::nil => Some(Val.notl v1) - | Oshll, v1::v2::nil => Some (Val.shll v1 v2) - | Oshllimm n, v1::nil => Some (Val.shll v1 (Vint n)) - | Oshrl, v1::v2::nil => Some (Val.shrl v1 v2) - | Oshrlimm n, v1::nil => Some (Val.shrl v1 (Vint n)) - | Oshrxlimm n, v1::nil => Val.shrxl v1 (Vint n) - | Oshrlu, v1::v2::nil => Some (Val.shrlu v1 v2) - | Oshrluimm n, v1::nil => Some (Val.shrlu v1 (Vint n)) - | Ororlimm n, v1::nil => Some (Val.rorl v1 (Vint n)) - | Oleal addr, _ => eval_addressing64 genv sp addr vl - | Onegf, v1::nil => Some(Val.negf v1) - | Oabsf, v1::nil => Some(Val.absf v1) - | Oaddf, v1::v2::nil => Some(Val.addf v1 v2) - | Osubf, v1::v2::nil => Some(Val.subf v1 v2) - | Omulf, v1::v2::nil => Some(Val.mulf v1 v2) - | Odivf, v1::v2::nil => Some(Val.divf v1 v2) - | Onegfs, v1::nil => Some(Val.negfs v1) - | Oabsfs, v1::nil => Some(Val.absfs v1) - | Oaddfs, v1::v2::nil => Some(Val.addfs v1 v2) - | Osubfs, v1::v2::nil => Some(Val.subfs v1 v2) - | Omulfs, v1::v2::nil => Some(Val.mulfs v1 v2) - | Odivfs, v1::v2::nil => Some(Val.divfs v1 v2) - | Osingleoffloat, v1::nil => Some(Val.singleoffloat v1) - | Ofloatofsingle, v1::nil => Some(Val.floatofsingle v1) - | Ointoffloat, v1::nil => Val.intoffloat v1 - | Ofloatofint, v1::nil => Val.floatofint v1 - | Ointofsingle, v1::nil => Val.intofsingle v1 - | Osingleofint, v1::nil => Val.singleofint v1 - | Olongoffloat, v1::nil => Val.longoffloat v1 - | Ofloatoflong, v1::nil => Val.floatoflong v1 - | Olongofsingle, v1::nil => Val.longofsingle v1 - | Osingleoflong, v1::nil => Val.singleoflong v1 - | Ocmp c, _ => Some(Val.of_optbool (eval_condition c vl m)) - | _, _ => None - end. - -Remark eval_addressing_Aglobal: - forall (F V: Type) (genv: Genv.t F V) sp id ofs, - eval_addressing genv sp (Aglobal id ofs) nil = Some (Genv.symbol_address genv id ofs). -Proof. - intros. unfold eval_addressing, eval_addressing32, eval_addressing64; destruct Archi.ptr64; auto. -Qed. - -Remark eval_addressing_Ainstack: - forall (F V: Type) (genv: Genv.t F V) sp ofs, - eval_addressing genv sp (Ainstack ofs) nil = Some (Val.offset_ptr sp ofs). -Proof. - intros. unfold eval_addressing, eval_addressing32, eval_addressing64; destruct Archi.ptr64; auto. -Qed. - -Remark eval_addressing_Ainstack_inv: - forall (F V: Type) (genv: Genv.t F V) sp ofs vl v, - eval_addressing genv sp (Ainstack ofs) vl = Some v -> vl = nil /\ v = Val.offset_ptr sp ofs. -Proof. - unfold eval_addressing, eval_addressing32, eval_addressing64; - intros; destruct Archi.ptr64; destruct vl; inv H; auto. -Qed. - -Ltac FuncInv := - match goal with - | H: (match ?x with nil => _ | _ :: _ => _ end = Some _) |- _ => - destruct x; simpl in H; try discriminate H; FuncInv - | H: (match ?v with Vundef => _ | Vint _ => _ | Vfloat _ => _ | Vptr _ _ => _ end = Some _) |- _ => - destruct v; simpl in H; try discriminate H; FuncInv - | H: (if Archi.ptr64 then _ else _) = Some _ |- _ => - destruct Archi.ptr64 eqn:?; try discriminate H; FuncInv - | H: (Some _ = Some _) |- _ => - injection H; intros; clear H; FuncInv - | H: (None = Some _) |- _ => - discriminate H - | _ => - idtac - end. - -(** * Static typing of conditions, operators and addressing modes. *) - -Definition type_of_condition (c: condition) : list typ := - match c with - | Ccomp _ => Tint :: Tint :: nil - | Ccompu _ => Tint :: Tint :: nil - | Ccompimm _ _ => Tint :: nil - | Ccompuimm _ _ => Tint :: nil - | Ccompl _ => Tlong :: Tlong :: nil - | Ccomplu _ => Tlong :: Tlong :: nil - | Ccomplimm _ _ => Tlong :: nil - | Ccompluimm _ _ => Tlong :: nil - | Ccompf _ => Tfloat :: Tfloat :: nil - | Cnotcompf _ => Tfloat :: Tfloat :: nil - | Ccompfs _ => Tsingle :: Tsingle :: nil - | Cnotcompfs _ => Tsingle :: Tsingle :: nil - | Cmaskzero _ => Tint :: nil - | Cmasknotzero _ => Tint :: nil - end. - -Definition type_of_addressing_gen (tyA: typ) (addr: addressing): list typ := - match addr with - | Aindexed _ => tyA :: nil - | Aindexed2 _ => tyA :: tyA :: nil - | Ascaled _ _ => tyA :: nil - | Aindexed2scaled _ _ => tyA :: tyA :: nil - | Aglobal _ _ => nil - | Abased _ _ => tyA :: nil - | Abasedscaled _ _ _ => tyA :: nil - | Ainstack _ => nil - end. - -Definition type_of_addressing := type_of_addressing_gen Tptr. -Definition type_of_addressing32 := type_of_addressing_gen Tint. -Definition type_of_addressing64 := type_of_addressing_gen Tlong. - -Definition type_of_operation (op: operation) : list typ * typ := - match op with - | Omove => (nil, Tint) (* treated specially *) - | Ointconst _ => (nil, Tint) - | Olongconst _ => (nil, Tlong) - | Ofloatconst f => (nil, Tfloat) - | Osingleconst f => (nil, Tsingle) - | Oindirectsymbol _ => (nil, Tptr) - | Ocast8signed => (Tint :: nil, Tint) - | Ocast8unsigned => (Tint :: nil, Tint) - | Ocast16signed => (Tint :: nil, Tint) - | Ocast16unsigned => (Tint :: nil, Tint) - | Oneg => (Tint :: nil, Tint) - | Osub => (Tint :: Tint :: nil, Tint) - | Omul => (Tint :: Tint :: nil, Tint) - | Omulimm _ => (Tint :: nil, Tint) - | Omulhs => (Tint :: Tint :: nil, Tint) - | Omulhu => (Tint :: Tint :: nil, Tint) - | Odiv => (Tint :: Tint :: nil, Tint) - | Odivu => (Tint :: Tint :: nil, Tint) - | Omod => (Tint :: Tint :: nil, Tint) - | Omodu => (Tint :: Tint :: nil, Tint) - | Oand => (Tint :: Tint :: nil, Tint) - | Oandimm _ => (Tint :: nil, Tint) - | Oor => (Tint :: Tint :: nil, Tint) - | Oorimm _ => (Tint :: nil, Tint) - | Oxor => (Tint :: Tint :: nil, Tint) - | Oxorimm _ => (Tint :: nil, Tint) - | Onot => (Tint :: nil, Tint) - | Oshl => (Tint :: Tint :: nil, Tint) - | Oshlimm _ => (Tint :: nil, Tint) - | Oshr => (Tint :: Tint :: nil, Tint) - | Oshrimm _ => (Tint :: nil, Tint) - | Oshrximm _ => (Tint :: nil, Tint) - | Oshru => (Tint :: Tint :: nil, Tint) - | Oshruimm _ => (Tint :: nil, Tint) - | Ororimm _ => (Tint :: nil, Tint) - | Oshldimm _ => (Tint :: Tint :: nil, Tint) - | Olea addr => (type_of_addressing32 addr, Tint) - | Omakelong => (Tint :: Tint :: nil, Tlong) - | Olowlong => (Tlong :: nil, Tint) - | Ohighlong => (Tlong :: nil, Tint) - | Ocast32signed => (Tint :: nil, Tlong) - | Ocast32unsigned => (Tint :: nil, Tlong) - | Onegl => (Tlong :: nil, Tlong) - | Oaddlimm _ => (Tlong :: nil, Tlong) - | Osubl => (Tlong :: Tlong :: nil, Tlong) - | Omull => (Tlong :: Tlong :: nil, Tlong) - | Omullimm _ => (Tlong :: nil, Tlong) - | Omullhs => (Tlong :: Tlong :: nil, Tlong) - | Omullhu => (Tlong :: Tlong :: nil, Tlong) - | Odivl => (Tlong :: Tlong :: nil, Tlong) - | Odivlu => (Tlong :: Tlong :: nil, Tlong) - | Omodl => (Tlong :: Tlong :: nil, Tlong) - | Omodlu => (Tlong :: Tlong :: nil, Tlong) - | Oandl => (Tlong :: Tlong :: nil, Tlong) - | Oandlimm _ => (Tlong :: nil, Tlong) - | Oorl => (Tlong :: Tlong :: nil, Tlong) - | Oorlimm _ => (Tlong :: nil, Tlong) - | Oxorl => (Tlong :: Tlong :: nil, Tlong) - | Oxorlimm _ => (Tlong :: nil, Tlong) - | Onotl => (Tlong :: nil, Tlong) - | Oshll => (Tlong :: Tint :: nil, Tlong) - | Oshllimm _ => (Tlong :: nil, Tlong) - | Oshrl => (Tlong :: Tint :: nil, Tlong) - | Oshrlimm _ => (Tlong :: nil, Tlong) - | Oshrxlimm _ => (Tlong :: nil, Tlong) - | Oshrlu => (Tlong :: Tint :: nil, Tlong) - | Oshrluimm _ => (Tlong :: nil, Tlong) - | Ororlimm _ => (Tlong :: nil, Tlong) - | Oleal addr => (type_of_addressing64 addr, Tlong) - | Onegf => (Tfloat :: nil, Tfloat) - | Oabsf => (Tfloat :: nil, Tfloat) - | Oaddf => (Tfloat :: Tfloat :: nil, Tfloat) - | Osubf => (Tfloat :: Tfloat :: nil, Tfloat) - | Omulf => (Tfloat :: Tfloat :: nil, Tfloat) - | Odivf => (Tfloat :: Tfloat :: nil, Tfloat) - | Onegfs => (Tsingle :: nil, Tsingle) - | Oabsfs => (Tsingle :: nil, Tsingle) - | Oaddfs => (Tsingle :: Tsingle :: nil, Tsingle) - | Osubfs => (Tsingle :: Tsingle :: nil, Tsingle) - | Omulfs => (Tsingle :: Tsingle :: nil, Tsingle) - | Odivfs => (Tsingle :: Tsingle :: nil, Tsingle) - | Osingleoffloat => (Tfloat :: nil, Tsingle) - | Ofloatofsingle => (Tsingle :: nil, Tfloat) - | Ointoffloat => (Tfloat :: nil, Tint) - | Ofloatofint => (Tint :: nil, Tfloat) - | Ointofsingle => (Tsingle :: nil, Tint) - | Osingleofint => (Tint :: nil, Tsingle) - | Olongoffloat => (Tfloat :: nil, Tlong) - | Ofloatoflong => (Tlong :: nil, Tfloat) - | Olongofsingle => (Tsingle :: nil, Tlong) - | Osingleoflong => (Tlong :: nil, Tsingle) - | Ocmp c => (type_of_condition c, Tint) - end. - -(** Weak type soundness results for [eval_operation]: - the result values, when defined, are always of the type predicted - by [type_of_operation]. *) - -Section SOUNDNESS. - -Variable A V: Type. -Variable genv: Genv.t A V. - -Remark type_add: - forall v1 v2, Val.has_type (Val.add v1 v2) Tint. -Proof. - intros. unfold Val.has_type, Val.add. destruct Archi.ptr64, v1, v2; auto. -Qed. - -Remark type_addl: - forall v1 v2, Val.has_type (Val.addl v1 v2) Tlong. -Proof. - intros. unfold Val.has_type, Val.addl. destruct Archi.ptr64, v1, v2; auto. -Qed. - -Lemma type_of_addressing64_sound: - forall addr vl sp v, - eval_addressing64 genv sp addr vl = Some v -> - Val.has_type v Tlong. -Proof. - intros. destruct addr; simpl in H; FuncInv; subst; simpl; auto using type_addl. -- unfold Genv.symbol_address; destruct (Genv.find_symbol genv i); simpl; auto. -- destruct sp; simpl; auto. -Qed. - -Lemma type_of_addressing32_sound: - forall addr vl sp v, - eval_addressing32 genv sp addr vl = Some v -> - Val.has_type v Tint. -Proof. - intros. destruct addr; simpl in H; FuncInv; subst; simpl; auto using type_add. -- unfold Genv.symbol_address; destruct (Genv.find_symbol genv i); simpl; auto. -- destruct sp; simpl; auto. -Qed. - -Corollary type_of_addressing_sound: - forall addr vl sp v, - eval_addressing genv sp addr vl = Some v -> - Val.has_type v Tptr. -Proof. - unfold eval_addressing, Tptr; intros. - destruct Archi.ptr64; eauto using type_of_addressing64_sound, type_of_addressing32_sound. -Qed. - -Lemma type_of_operation_sound: - forall op vl sp v m, - op <> Omove -> - eval_operation genv sp op vl m = Some v -> - Val.has_type v (snd (type_of_operation op)). -Proof with (try exact I). - 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)... - unfold Val.has_type, Tptr; destruct Archi.ptr64; auto. - destruct v0... - destruct v0... - destruct v0... - destruct v0... - destruct v0... - destruct v0; destruct v1; simpl... - unfold Val.has_type; destruct Archi.ptr64; auto. - unfold Val.has_type; destruct Archi.ptr64; auto. destruct (eq_block b b0); auto. - 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... - destruct v0; simpl... unfold Val.has_type; destruct Archi.ptr64; auto. - destruct v0; destruct v1; simpl... - unfold Val.has_type; destruct Archi.ptr64; auto. - unfold Val.has_type; destruct Archi.ptr64; simpl; auto. destruct (eq_block b b0); auto. - destruct v0; destruct v1... - destruct v0... - destruct v0; destruct v1... - destruct v0; destruct v1... - destruct v0; destruct v1; simpl in *; inv H0. - destruct (Int64.eq i0 Int64.zero || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2... - destruct v0; destruct v1; simpl in *; inv H0. destruct (Int64.eq i0 Int64.zero); inv H2... - destruct v0; destruct v1; simpl in *; inv H0. - destruct (Int64.eq i0 Int64.zero || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2... - destruct v0; destruct v1; simpl in *; inv H0. destruct (Int64.eq i0 Int64.zero); inv H2... - destruct v0; destruct v1... - destruct v0... - destruct v0; destruct v1... - destruct v0... - destruct v0; destruct v1... - destruct v0... - destruct v0... - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... - destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')... - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... - destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')... - destruct v0; inv H0. destruct (Int.ltu n (Int.repr 63)); inv H2... - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... - destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')... - destruct v0... - eapply type_of_addressing64_sound; eauto. - destruct v0... - destruct v0... - destruct v0; destruct v1... - destruct v0; destruct v1... - destruct v0; destruct v1... - destruct v0; destruct v1... - destruct v0... - destruct v0... - destruct v0; destruct v1... - destruct v0; destruct v1... - destruct v0; destruct v1... - destruct v0; destruct v1... - destruct v0... - destruct v0... - destruct v0; simpl in H0; inv H0. destruct (Float.to_int f); inv H2... - destruct v0; simpl in H0; inv H0... - destruct v0; simpl in H0; inv H0. destruct (Float32.to_int f); inv H2... - destruct v0; simpl in H0; inv H0... - destruct v0; simpl in H0; inv H0. destruct (Float.to_long f); inv H2... - destruct v0; simpl in H0; inv H0... - destruct v0; simpl in H0; inv H0. destruct (Float32.to_long f); inv H2... - destruct v0; simpl in H0; inv H0... - destruct (eval_condition cond vl m); simpl... destruct b... -Qed. - -End SOUNDNESS. - -(** * Manipulating and transforming operations *) - -(** Recognition of move operations. *) - -Definition is_move_operation - (A: Type) (op: operation) (args: list A) : option A := - match op, args with - | Omove, arg :: nil => Some arg - | _, _ => None - end. - -Lemma is_move_operation_correct: - forall (A: Type) (op: operation) (args: list A) (a: A), - is_move_operation op args = Some a -> - op = Omove /\ args = a :: nil. -Proof. - intros until a. unfold is_move_operation; destruct op; - try (intros; discriminate). - destruct args. intros; discriminate. - destruct args. intros. intuition congruence. - intros; discriminate. -Qed. - -(** [negate_condition cond] returns a condition that is logically - equivalent to the negation of [cond]. *) - -Definition negate_condition (cond: condition): condition := - match cond with - | Ccomp c => Ccomp(negate_comparison c) - | Ccompu c => Ccompu(negate_comparison c) - | Ccompimm c n => Ccompimm (negate_comparison c) n - | Ccompuimm c n => Ccompuimm (negate_comparison c) n - | Ccompl c => Ccompl(negate_comparison c) - | Ccomplu c => Ccomplu(negate_comparison c) - | Ccomplimm c n => Ccomplimm (negate_comparison c) n - | Ccompluimm c n => Ccompluimm (negate_comparison c) n - | Ccompf c => Cnotcompf c - | Cnotcompf c => Ccompf c - | Ccompfs c => Cnotcompfs c - | Cnotcompfs c => Ccompfs c - | Cmaskzero n => Cmasknotzero n - | Cmasknotzero n => Cmaskzero n - end. - -Lemma eval_negate_condition: - forall cond vl m, - eval_condition (negate_condition cond) vl m = option_map negb (eval_condition cond vl m). -Proof. - intros. destruct cond; simpl. - repeat (destruct vl; auto). apply Val.negate_cmp_bool. - repeat (destruct vl; auto). apply Val.negate_cmpu_bool. - repeat (destruct vl; auto). apply Val.negate_cmp_bool. - repeat (destruct vl; auto). apply Val.negate_cmpu_bool. - repeat (destruct vl; auto). apply Val.negate_cmpl_bool. - repeat (destruct vl; auto). apply Val.negate_cmplu_bool. - repeat (destruct vl; auto). apply Val.negate_cmpl_bool. - repeat (destruct vl; auto). apply Val.negate_cmplu_bool. - repeat (destruct vl; auto). - repeat (destruct vl; auto). destruct (Val.cmpf_bool c v v0) as [[]|]; auto. - repeat (destruct vl; auto). - repeat (destruct vl; auto). destruct (Val.cmpfs_bool c v v0) as [[]|]; auto. - destruct vl; auto. destruct vl; auto. - destruct vl; auto. destruct vl; auto. destruct (Val.maskzero_bool v n) as [[]|]; auto. -Qed. - -(** Shifting stack-relative references. This is used in [Stacking]. *) - -Definition shift_stack_addressing (delta: Z) (addr: addressing) := - match addr with - | Ainstack ofs => Ainstack (Ptrofs.add ofs (Ptrofs.repr delta)) - | _ => addr - end. - -Definition shift_stack_operation (delta: Z) (op: operation) := - match op with - | Olea addr => Olea (shift_stack_addressing delta addr) - | Oleal addr => Oleal (shift_stack_addressing delta addr) - | _ => op - end. - -Lemma type_shift_stack_addressing: - forall delta addr, type_of_addressing (shift_stack_addressing delta addr) = type_of_addressing addr. -Proof. - intros. destruct addr; auto. -Qed. - -Lemma type_shift_stack_operation: - forall delta op, type_of_operation (shift_stack_operation delta op) = type_of_operation op. -Proof. - intros. destruct op; auto; simpl; decEq; destruct a; auto. -Qed. - -Lemma eval_shift_stack_addressing32: - forall F V (ge: Genv.t F V) sp addr vl delta, - eval_addressing32 ge (Vptr sp Ptrofs.zero) (shift_stack_addressing delta addr) vl = - eval_addressing32 ge (Vptr sp (Ptrofs.repr delta)) addr vl. -Proof. - intros. destruct addr; simpl; auto. - destruct vl; auto. destruct Archi.ptr64 eqn:SF; auto. - do 2 f_equal. rewrite Ptrofs.add_zero_l. apply Ptrofs.add_commut. -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. destruct addr; simpl; auto. - destruct vl; auto. destruct Archi.ptr64 eqn:SF; auto. - do 2 f_equal. rewrite Ptrofs.add_zero_l. apply Ptrofs.add_commut. -Qed. - -Lemma eval_shift_stack_addressing: - forall F V (ge: Genv.t F V) sp addr vl delta, - eval_addressing ge (Vptr sp Ptrofs.zero) (shift_stack_addressing delta addr) vl = - eval_addressing ge (Vptr sp (Ptrofs.repr delta)) addr vl. -Proof. - intros. unfold eval_addressing. - destruct Archi.ptr64; auto using eval_shift_stack_addressing32, eval_shift_stack_addressing64. -Qed. - -Lemma eval_shift_stack_operation: - forall F V (ge: Genv.t F V) sp op vl m delta, - eval_operation ge (Vptr sp Ptrofs.zero) (shift_stack_operation delta op) vl m = - eval_operation ge (Vptr sp (Ptrofs.repr delta)) op vl m. -Proof. - intros. destruct op; simpl; auto using eval_shift_stack_addressing32, eval_shift_stack_addressing64. -Qed. - -(** Offset an addressing mode [addr] by a quantity [delta], so that - it designates the pointer [delta] bytes past the pointer designated - by [addr]. This may be undefined if an offset overflows, in which case - [None] is returned. *) - -Definition offset_addressing_total (addr: addressing) (delta: Z) : addressing := - match addr with - | Aindexed n => Aindexed (n + delta) - | Aindexed2 n => Aindexed2 (n + delta) - | Ascaled sc n => Ascaled sc (n + delta) - | Aindexed2scaled sc n => Aindexed2scaled sc (n + delta) - | Aglobal s n => Aglobal s (Ptrofs.add n (Ptrofs.repr delta)) - | Abased s n => Abased s (Ptrofs.add n (Ptrofs.repr delta)) - | Abasedscaled sc s n => Abasedscaled sc s (Ptrofs.add n (Ptrofs.repr delta)) - | Ainstack n => Ainstack (Ptrofs.add n (Ptrofs.repr delta)) - end. - -Definition offset_addressing (addr: addressing) (delta: Z) : option addressing := - let addr' := offset_addressing_total addr delta in - if addressing_valid addr' then Some addr' else None. - -Lemma eval_offset_addressing_total_32: - forall (F V: Type) (ge: Genv.t F V) sp addr args delta v, - eval_addressing32 ge sp addr args = Some v -> - eval_addressing32 ge sp (offset_addressing_total addr delta) args = Some(Val.add v (Vint (Int.repr delta))). -Proof. - assert (A: forall x y, Int.add (Int.repr x) (Int.repr y) = Int.repr (x + y)). - { intros. apply Int.eqm_samerepr; auto with ints. } - assert (B: forall delta, Archi.ptr64 = false -> Ptrofs.repr delta = Ptrofs.of_int (Int.repr delta)). - { intros; symmetry; auto with ptrofs. } - intros. destruct addr; simpl in *; FuncInv; subst; simpl. -- rewrite <- A, ! Val.add_assoc; auto. -- rewrite <- A, ! Val.add_assoc; auto. -- rewrite <- A, ! Val.add_assoc; auto. -- rewrite <- A, ! Val.add_assoc; auto. -- rewrite B, Genv.shift_symbol_address_32 by auto. auto. -- rewrite B, Genv.shift_symbol_address_32 by auto. rewrite ! Val.add_assoc. do 2 f_equal. apply Val.add_commut. -- rewrite B, Genv.shift_symbol_address_32 by auto. rewrite ! Val.add_assoc. do 2 f_equal. apply Val.add_commut. -- destruct sp; simpl; auto. rewrite Heqb. rewrite Ptrofs.add_assoc. do 4 f_equal. symmetry; auto with ptrofs. -Qed. - -Lemma eval_offset_addressing_total_64: - forall (F V: Type) (ge: Genv.t F V) sp addr args delta v, - eval_addressing64 ge sp addr args = Some v -> - eval_addressing64 ge sp (offset_addressing_total addr delta) args = Some(Val.addl v (Vlong (Int64.repr delta))). -Proof. - assert (A: forall x y, Int64.add (Int64.repr x) (Int64.repr y) = Int64.repr (x + y)). - { intros. apply Int64.eqm_samerepr; auto with ints. } - assert (B: forall delta, Archi.ptr64 = true -> Ptrofs.repr delta = Ptrofs.of_int64 (Int64.repr delta)). - { intros; symmetry; auto with ptrofs. } - intros. destruct addr; simpl in *; FuncInv; subst; simpl. -- rewrite <- A, ! Val.addl_assoc; auto. -- rewrite <- A, ! Val.addl_assoc; auto. -- rewrite <- A, ! Val.addl_assoc; auto. -- rewrite <- A, ! Val.addl_assoc; auto. -- rewrite B, Genv.shift_symbol_address_64 by auto. auto. -- destruct sp; simpl; auto. rewrite Heqb. rewrite Ptrofs.add_assoc. do 4 f_equal. symmetry; auto with ptrofs. -Qed. - -(** The following lemma is used only in [Allocproof] in cases where [Archi.ptr64 = false]. *) - -Lemma eval_offset_addressing: - forall (F V: Type) (ge: Genv.t F V) sp addr args delta addr' v, - offset_addressing addr delta = Some addr' -> - eval_addressing ge sp addr args = Some v -> - Archi.ptr64 = false -> - eval_addressing ge sp addr' args = Some(Val.add v (Vint (Int.repr delta))). -Proof. - intros. unfold offset_addressing in H. destruct (addressing_valid (offset_addressing_total addr delta)); inv H. - unfold eval_addressing in *; rewrite H1 in *. apply eval_offset_addressing_total_32; auto. -Qed. - -(** Operations that are so cheap to recompute that CSE should not factor them out. *) - -Definition is_trivial_op (op: operation) : bool := - match op with - | Omove => true - | Ointconst _ => true - | Olongconst _ => true - | Olea (Aglobal _ _) => true - | Olea (Ainstack _) => true - | Oleal (Aglobal _ _) => true - | Oleal (Ainstack _) => true - | _ => false - end. - -(** Operations that depend on the memory state. *) - -Definition op_depends_on_memory (op: operation) : bool := - match op with - | Ocmp (Ccompu _) => negb Archi.ptr64 - | Ocmp (Ccompuimm _ _) => negb Archi.ptr64 - | Ocmp (Ccomplu _) => Archi.ptr64 - | Ocmp (Ccompluimm _ _) => Archi.ptr64 - | _ => false - end. - -Lemma op_depends_on_memory_correct: - forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2, - op_depends_on_memory op = false -> - eval_operation ge sp op args m1 = eval_operation ge sp op args m2. -Proof. - intros until m2. destruct op; simpl; try congruence. - destruct cond; simpl; intros SF; auto; rewrite ? negb_false_iff in SF; - unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. -Qed. - -(** Global variables mentioned in an operation or addressing mode *) - -Definition globals_addressing (addr: addressing) : list ident := - match addr with - | Aglobal s n => s :: nil - | Abased s n => s :: nil - | Abasedscaled sc s n => s :: nil - | _ => nil - end. - -Definition globals_operation (op: operation) : list ident := - match op with - | Oindirectsymbol s => s :: nil - | Olea addr => globals_addressing addr - | Oleal addr => globals_addressing addr - | _ => nil - end. - -(** * Invariance and compatibility properties. *) - -(** [eval_operation] and [eval_addressing] depend on a global environment - for resolving references to global symbols. We show that they give - the same results if a global environment is replaced by another that - assigns the same addresses to the same symbols. *) - -Section GENV_TRANSF. - -Variable F1 F2 V1 V2: Type. -Variable ge1: Genv.t F1 V1. -Variable ge2: Genv.t F2 V2. -Hypothesis agree_on_symbols: - forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s. - -Lemma eval_addressing32_preserved: - forall sp addr vl, - eval_addressing32 ge2 sp addr vl = eval_addressing32 ge1 sp addr vl. -Proof. - intros. - unfold eval_addressing32, Genv.symbol_address; destruct addr; try rewrite agree_on_symbols; - reflexivity. -Qed. - -Lemma eval_addressing64_preserved: - forall sp addr vl, - eval_addressing64 ge2 sp addr vl = eval_addressing64 ge1 sp addr vl. -Proof. - intros. - unfold eval_addressing64, Genv.symbol_address; destruct addr; try rewrite agree_on_symbols; - reflexivity. -Qed. - -Lemma eval_addressing_preserved: - forall sp addr vl, - eval_addressing ge2 sp addr vl = eval_addressing ge1 sp addr vl. -Proof. - intros. - unfold eval_addressing; destruct Archi.ptr64; auto using eval_addressing32_preserved, eval_addressing64_preserved. -Qed. - -Lemma eval_operation_preserved: - forall sp op vl m, - eval_operation ge2 sp op vl m = eval_operation ge1 sp op vl m. -Proof. - intros. - unfold eval_operation; destruct op; auto. - unfold Genv.symbol_address. rewrite agree_on_symbols. auto. - apply eval_addressing32_preserved. - apply eval_addressing64_preserved. -Qed. - -End GENV_TRANSF. - -(** Compatibility of the evaluation functions with value injections. *) - -Section EVAL_COMPAT. - -Variable F1 F2 V1 V2: Type. -Variable ge1: Genv.t F1 V1. -Variable ge2: Genv.t F2 V2. -Variable f: meminj. - -Variable m1: mem. -Variable m2: mem. - -Hypothesis valid_pointer_inj: - forall b1 ofs b2 delta, - f b1 = Some(b2, delta) -> - Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> - Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. - -Hypothesis weak_valid_pointer_inj: - forall b1 ofs b2 delta, - f b1 = Some(b2, delta) -> - Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> - Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. - -Hypothesis weak_valid_pointer_no_overflow: - forall b1 ofs b2 delta, - f b1 = Some(b2, delta) -> - Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> - 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. - -Hypothesis valid_different_pointers_inj: - forall b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, - b1 <> b2 -> - Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true -> - Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true -> - f b1 = Some (b1', delta1) -> - f b2 = Some (b2', delta2) -> - b1' <> b2' \/ - Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned (Ptrofs.add ofs2 (Ptrofs.repr delta2)). - -Ltac InvInject := - match goal with - | [ H: Val.inject _ (Vint _) _ |- _ ] => - inv H; InvInject - | [ H: Val.inject _ (Vfloat _) _ |- _ ] => - inv H; InvInject - | [ H: Val.inject _ (Vptr _ _) _ |- _ ] => - inv H; InvInject - | [ H: Val.inject_list _ nil _ |- _ ] => - inv H; InvInject - | [ H: Val.inject_list _ (_ :: _) _ |- _ ] => - inv H; InvInject - | _ => idtac - end. - -Lemma eval_condition_inj: - forall cond vl1 vl2 b, - Val.inject_list f vl1 vl2 -> - eval_condition cond vl1 m1 = Some b -> - eval_condition cond vl2 m2 = Some b. -Proof. - intros. destruct cond; simpl in H0; FuncInv; InvInject; simpl; auto. -- inv H3; inv H2; simpl in H0; inv H0; auto. -- eauto 3 using Val.cmpu_bool_inject, Mem.valid_pointer_implies. -- inv H3; simpl in H0; inv H0; auto. -- eauto 3 using Val.cmpu_bool_inject, Mem.valid_pointer_implies. -- inv H3; inv H2; simpl in H0; inv H0; auto. -- eauto 3 using Val.cmplu_bool_inject, Mem.valid_pointer_implies. -- inv H3; simpl in H0; inv H0; auto. -- eauto 3 using Val.cmplu_bool_inject, Mem.valid_pointer_implies. -- inv H3; inv H2; simpl in H0; inv H0; auto. -- inv H3; inv H2; simpl in H0; inv H0; auto. -- inv H3; inv H2; simpl in H0; inv H0; auto. -- inv H3; inv H2; simpl in H0; inv H0; auto. -- inv H3; try discriminate; auto. -- inv H3; try discriminate; auto. -Qed. - -Ltac TrivialExists := - match goal with - | [ |- exists v2, Some ?v1 = Some v2 /\ Val.inject _ _ v2 ] => - exists v1; split; auto - | _ => idtac - end. - -Lemma eval_addressing32_inj: - forall addr sp1 vl1 sp2 vl2 v1, - (forall id ofs, - In id (globals_addressing addr) -> - Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) -> - Val.inject f sp1 sp2 -> - Val.inject_list f vl1 vl2 -> - eval_addressing32 ge1 sp1 addr vl1 = Some v1 -> - exists v2, eval_addressing32 ge2 sp2 addr vl2 = Some v2 /\ Val.inject f v1 v2. -Proof. - assert (A: forall v1 v2 v1' v2', Val.inject f v1 v1' -> Val.inject f v2 v2' -> Val.inject f (Val.mul v1 v2) (Val.mul v1' v2')). - { intros. inv H; simpl; auto. inv H0; auto. } - intros. destruct addr; simpl in *; FuncInv; InvInject; TrivialExists; eauto using Val.add_inject, Val.offset_ptr_inject with coqlib. -Qed. - -Lemma eval_addressing64_inj: - forall addr sp1 vl1 sp2 vl2 v1, - (forall id ofs, - In id (globals_addressing addr) -> - Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) -> - Val.inject f sp1 sp2 -> - Val.inject_list f vl1 vl2 -> - eval_addressing64 ge1 sp1 addr vl1 = Some v1 -> - exists v2, eval_addressing64 ge2 sp2 addr vl2 = Some v2 /\ Val.inject f v1 v2. -Proof. - assert (A: forall v1 v2 v1' v2', Val.inject f v1 v1' -> Val.inject f v2 v2' -> Val.inject f (Val.mull v1 v2) (Val.mull v1' v2')). - { intros. inv H; simpl; auto. inv H0; auto. } - intros. destruct addr; simpl in *; FuncInv; InvInject; TrivialExists; eauto using Val.addl_inject, Val.offset_ptr_inject with coqlib. -Qed. - -Lemma eval_addressing_inj: - forall addr sp1 vl1 sp2 vl2 v1, - (forall id ofs, - In id (globals_addressing addr) -> - Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) -> - Val.inject f sp1 sp2 -> - Val.inject_list f vl1 vl2 -> - eval_addressing ge1 sp1 addr vl1 = Some v1 -> - exists v2, eval_addressing ge2 sp2 addr vl2 = Some v2 /\ Val.inject f v1 v2. -Proof. - unfold eval_addressing; intros. destruct Archi.ptr64; eauto using eval_addressing32_inj, eval_addressing64_inj. -Qed. - -Lemma eval_operation_inj: - forall op sp1 vl1 sp2 vl2 v1, - (forall id ofs, - In id (globals_operation op) -> - Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) -> - Val.inject f sp1 sp2 -> - Val.inject_list f vl1 vl2 -> - eval_operation ge1 sp1 op vl1 m1 = Some v1 -> - exists v2, eval_operation ge2 sp2 op vl2 m2 = Some v2 /\ Val.inject f v1 v2. -Proof. - intros until v1; intros GL; intros. destruct op; simpl in H1; simpl; FuncInv; InvInject; TrivialExists. - apply GL; simpl; auto. - inv H4; simpl; auto. - inv H4; simpl; auto. - inv H4; simpl; auto. - inv H4; simpl; auto. - inv H4; simpl; auto. - apply Val.sub_inject; auto. - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2. TrivialExists. - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2. TrivialExists. - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. - inv H4; simpl; auto. - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. - inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. - inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. - inv H4; simpl in H1; try discriminate. simpl. - destruct (Int.ltu n (Int.repr 31)); inv H1. TrivialExists. - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. - inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. - inv H4; simpl; auto. - inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. - inv H2; simpl; auto. destruct (Int.ltu (Int.sub Int.iwordsize n) Int.iwordsize); auto. - eapply eval_addressing32_inj; eauto. - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. - inv H4; simpl; auto. - inv H4; simpl; auto. - inv H4; simpl; auto. - inv H4; simpl; auto. - apply Val.addl_inject; auto. - apply Val.subl_inject; auto. - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int64.eq i0 Int64.zero || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2. TrivialExists. - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int64.eq i0 Int64.zero); inv H2. TrivialExists. - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int64.eq i0 Int64.zero || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2. TrivialExists. - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int64.eq i0 Int64.zero); inv H2. TrivialExists. - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. - inv H4; simpl; auto. - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. - inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto. - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. - inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto. - inv H4; simpl in H1; try discriminate. simpl. destruct (Int.ltu n (Int.repr 63)); inv H1. TrivialExists. - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. - inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto. - inv H4; simpl; auto. - eapply eval_addressing64_inj; eauto. - inv H4; simpl; auto. - inv H4; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. - inv H4; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. - inv H4; simpl; auto. - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_int f0); simpl in H2; inv H2. - exists (Vint i); auto. - inv H4; simpl in H1; inv H1. simpl. TrivialExists. - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_int f0); simpl in H2; inv H2. - exists (Vint i); auto. - inv H4; simpl in H1; inv H1. simpl. TrivialExists. - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_long f0); simpl in H2; inv H2. - exists (Vlong i); auto. - inv H4; simpl in H1; inv H1. simpl. TrivialExists. - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_long f0); simpl in H2; inv H2. - exists (Vlong i); auto. - inv H4; simpl in H1; inv H1. simpl. TrivialExists. - subst v1. destruct (eval_condition cond vl1 m1) eqn:?. - exploit eval_condition_inj; eauto. intros EQ; rewrite EQ. - destruct b; simpl; constructor. - simpl; constructor. -Qed. - -End EVAL_COMPAT. - -(** Compatibility of the evaluation functions with the ``is less defined'' relation over values. *) - -Section EVAL_LESSDEF. - -Variable F V: Type. -Variable genv: Genv.t F V. - -Remark valid_pointer_extends: - forall m1 m2, Mem.extends m1 m2 -> - forall b1 ofs b2 delta, - Some(b1, 0) = Some(b2, delta) -> - Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> - Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. -Proof. - intros. inv H0. rewrite Ptrofs.add_zero. eapply Mem.valid_pointer_extends; eauto. -Qed. - -Remark weak_valid_pointer_extends: - forall m1 m2, Mem.extends m1 m2 -> - forall b1 ofs b2 delta, - Some(b1, 0) = Some(b2, delta) -> - Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> - Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. -Proof. - intros. inv H0. rewrite Ptrofs.add_zero. eapply Mem.weak_valid_pointer_extends; eauto. -Qed. - -Remark weak_valid_pointer_no_overflow_extends: - forall m1 b1 ofs b2 delta, - Some(b1, 0) = Some(b2, delta) -> - Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> - 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. -Proof. - intros. inv H. rewrite Zplus_0_r. apply Ptrofs.unsigned_range_2. -Qed. - -Remark valid_different_pointers_extends: - forall m1 b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, - b1 <> b2 -> - Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true -> - Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true -> - Some(b1, 0) = Some (b1', delta1) -> - Some(b2, 0) = Some (b2', delta2) -> - b1' <> b2' \/ - Ptrofs.unsigned(Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned(Ptrofs.add ofs2 (Ptrofs.repr delta2)). -Proof. - intros. inv H2; inv H3. auto. -Qed. - -Lemma eval_condition_lessdef: - forall cond vl1 vl2 b m1 m2, - Val.lessdef_list vl1 vl2 -> - Mem.extends m1 m2 -> - eval_condition cond vl1 m1 = Some b -> - eval_condition cond vl2 m2 = Some b. -Proof. - intros. eapply eval_condition_inj with (f := fun b => Some(b, 0)) (m1 := m1). - apply valid_pointer_extends; auto. - apply weak_valid_pointer_extends; auto. - apply weak_valid_pointer_no_overflow_extends. - apply valid_different_pointers_extends; auto. - rewrite <- val_inject_list_lessdef. eauto. auto. -Qed. - -Lemma eval_operation_lessdef: - forall sp op vl1 vl2 v1 m1 m2, - Val.lessdef_list vl1 vl2 -> - Mem.extends m1 m2 -> - eval_operation genv sp op vl1 m1 = Some v1 -> - exists v2, eval_operation genv sp op vl2 m2 = Some v2 /\ Val.lessdef v1 v2. -Proof. - intros. rewrite val_inject_list_lessdef in H. - assert (exists v2 : val, - eval_operation genv sp op vl2 m2 = Some v2 - /\ Val.inject (fun b => Some(b, 0)) v1 v2). - eapply eval_operation_inj with (m1 := m1) (sp1 := sp). - apply valid_pointer_extends; auto. - apply weak_valid_pointer_extends; auto. - apply weak_valid_pointer_no_overflow_extends. - apply valid_different_pointers_extends; auto. - intros. apply val_inject_lessdef. auto. - apply val_inject_lessdef; auto. - eauto. - auto. - destruct H2 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. -Qed. - -Lemma eval_addressing_lessdef: - forall sp addr vl1 vl2 v1, - Val.lessdef_list vl1 vl2 -> - eval_addressing genv sp addr vl1 = Some v1 -> - exists v2, eval_addressing genv sp addr vl2 = Some v2 /\ Val.lessdef v1 v2. -Proof. - intros. rewrite val_inject_list_lessdef in H. - assert (exists v2 : val, - eval_addressing genv sp addr vl2 = Some v2 - /\ Val.inject (fun b => Some(b, 0)) v1 v2). - eapply eval_addressing_inj with (sp1 := sp). - intros. rewrite <- val_inject_lessdef; auto. - rewrite <- val_inject_lessdef; auto. - eauto. auto. - destruct H1 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. -Qed. - -End EVAL_LESSDEF. - -(** Compatibility of the evaluation functions with memory injections. *) - -Section EVAL_INJECT. - -Variable F V: Type. -Variable genv: Genv.t F V. -Variable f: meminj. -Hypothesis globals: meminj_preserves_globals genv f. -Variable sp1: block. -Variable sp2: block. -Variable delta: Z. -Hypothesis sp_inj: f sp1 = Some(sp2, delta). - -Remark symbol_address_inject: - forall id ofs, Val.inject f (Genv.symbol_address genv id ofs) (Genv.symbol_address genv id ofs). -Proof. - intros. unfold Genv.symbol_address. destruct (Genv.find_symbol genv id) eqn:?; auto. - exploit (proj1 globals); eauto. intros. - econstructor; eauto. rewrite Ptrofs.add_zero; auto. -Qed. - -Lemma eval_condition_inject: - forall cond vl1 vl2 b m1 m2, - Val.inject_list f vl1 vl2 -> - Mem.inject f m1 m2 -> - eval_condition cond vl1 m1 = Some b -> - eval_condition cond vl2 m2 = Some b. -Proof. - intros. eapply eval_condition_inj with (f := f) (m1 := m1); eauto. - intros; eapply Mem.valid_pointer_inject_val; eauto. - intros; eapply Mem.weak_valid_pointer_inject_val; eauto. - intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto. - intros; eapply Mem.different_pointers_inject; eauto. -Qed. - -Lemma eval_addressing_inject: - forall addr vl1 vl2 v1, - Val.inject_list f vl1 vl2 -> - eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = Some v1 -> - exists v2, - eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = Some v2 - /\ Val.inject f v1 v2. -Proof. - intros. - rewrite eval_shift_stack_addressing. - eapply eval_addressing_inj with (sp1 := Vptr sp1 Ptrofs.zero); eauto. - intros. apply symbol_address_inject. - econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. -Qed. - -Lemma eval_operation_inject: - forall op vl1 vl2 v1 m1 m2, - Val.inject_list f vl1 vl2 -> - Mem.inject f m1 m2 -> - eval_operation genv (Vptr sp1 Ptrofs.zero) op vl1 m1 = Some v1 -> - exists v2, - eval_operation genv (Vptr sp2 Ptrofs.zero) (shift_stack_operation delta op) vl2 m2 = Some v2 - /\ Val.inject f v1 v2. -Proof. - intros. - rewrite eval_shift_stack_operation. simpl. - eapply eval_operation_inj with (sp1 := Vptr sp1 Ptrofs.zero) (m1 := m1); eauto. - intros; eapply Mem.valid_pointer_inject_val; eauto. - intros; eapply Mem.weak_valid_pointer_inject_val; eauto. - intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto. - intros; eapply Mem.different_pointers_inject; eauto. - intros. apply symbol_address_inject. - econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. -Qed. - -End EVAL_INJECT. diff --git a/ia32/PrintOp.ml b/ia32/PrintOp.ml deleted file mode 100644 index faa5bb5f..00000000 --- a/ia32/PrintOp.ml +++ /dev/null @@ -1,169 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Pretty-printing of operators, conditions, addressing modes *) - -open Printf -open Camlcoq -open Integers -open Op - -let comparison_name = function - | Ceq -> "==" - | Cne -> "!=" - | Clt -> "<" - | Cle -> "<=" - | Cgt -> ">" - | Cge -> ">=" - -let print_condition reg pp = function - | (Ccomp c, [r1;r2]) -> - fprintf pp "%a %ss %a" reg r1 (comparison_name c) reg r2 - | (Ccompu c, [r1;r2]) -> - fprintf pp "%a %su %a" reg r1 (comparison_name c) reg r2 - | (Ccompimm(c, n), [r1]) -> - fprintf pp "%a %ss %ld" reg r1 (comparison_name c) (camlint_of_coqint n) - | (Ccompuimm(c, n), [r1]) -> - fprintf pp "%a %su %lu" reg r1 (comparison_name c) (camlint_of_coqint n) - | (Ccompl c, [r1;r2]) -> - fprintf pp "%a %sls %a" reg r1 (comparison_name c) reg r2 - | (Ccomplu c, [r1;r2]) -> - fprintf pp "%a %slu %a" reg r1 (comparison_name c) reg r2 - | (Ccomplimm(c, n), [r1]) -> - fprintf pp "%a %sls %Ld" reg r1 (comparison_name c) (camlint64_of_coqint n) - | (Ccompluimm(c, n), [r1]) -> - fprintf pp "%a %slu %Lu" reg r1 (comparison_name c) (camlint64_of_coqint n) - | (Ccompf c, [r1;r2]) -> - fprintf pp "%a %sf %a" reg r1 (comparison_name c) reg r2 - | (Cnotcompf c, [r1;r2]) -> - fprintf pp "%a not(%sf) %a" reg r1 (comparison_name c) reg r2 - | (Ccompfs c, [r1;r2]) -> - fprintf pp "%a %sfs %a" reg r1 (comparison_name c) reg r2 - | (Cnotcompfs c, [r1;r2]) -> - fprintf pp "%a not(%sfs) %a" reg r1 (comparison_name c) reg r2 - | (Cmaskzero n, [r1]) -> - fprintf pp "%a & 0x%lx == 0" reg r1 (camlint_of_coqint n) - | (Cmasknotzero n, [r1]) -> - fprintf pp "%a & 0x%lx != 0" reg r1 (camlint_of_coqint n) - | _ -> - fprintf pp "<bad condition>" - -let print_addressing reg pp = function - | Aindexed n, [r1] -> - fprintf pp "%a + %s" reg r1 (Z.to_string n) - | Aindexed2 n, [r1; r2] -> - fprintf pp "%a + %a + %s" reg r1 reg r2 (Z.to_string n) - | Ascaled(sc,n), [r1] -> - fprintf pp "%a * %s + %s" reg r1 (Z.to_string sc) (Z.to_string n) - | Aindexed2scaled(sc, n), [r1; r2] -> - fprintf pp "%a + %a * %s + %s" reg r1 reg r2 (Z.to_string sc) (Z.to_string n) - | Aglobal(id, ofs), [] -> fprintf pp "%s + %s" (extern_atom id) (Z.to_string ofs) - | Abased(id, ofs), [r1] -> fprintf pp "%s + %s + %a" (extern_atom id) (Z.to_string ofs) reg r1 - | Abasedscaled(sc,id, ofs), [r1] -> fprintf pp "%s + %s + %a * %ld" (extern_atom id) (Z.to_string ofs) reg r1 (camlint_of_coqint sc) - | Ainstack ofs, [] -> fprintf pp "stack(%s)" (Z.to_string ofs) - | _ -> fprintf pp "<bad addressing>" - -let print_operation reg pp = function - | Omove, [r1] -> reg pp r1 - | Ointconst n, [] -> fprintf pp "%ld" (camlint_of_coqint n) - | Olongconst n, [] -> fprintf pp "%LdL" (camlint64_of_coqint n) - | Ofloatconst n, [] -> fprintf pp "%.15F" (camlfloat_of_coqfloat n) - | Osingleconst n, [] -> fprintf pp "%.15Ff" (camlfloat_of_coqfloat32 n) - | Oindirectsymbol id, [] -> fprintf pp "&%s" (extern_atom id) - | Ocast8signed, [r1] -> fprintf pp "int8signed(%a)" reg r1 - | Ocast8unsigned, [r1] -> fprintf pp "int8unsigned(%a)" reg r1 - | Ocast16signed, [r1] -> fprintf pp "int16signed(%a)" reg r1 - | Ocast16unsigned, [r1] -> fprintf pp "int16unsigned(%a)" reg r1 - | Oneg, [r1] -> fprintf pp "(- %a)" reg r1 - | Osub, [r1;r2] -> fprintf pp "%a - %a" reg r1 reg r2 - | Omul, [r1;r2] -> fprintf pp "%a * %a" reg r1 reg r2 - | Omulimm n, [r1] -> fprintf pp "%a * %ld" reg r1 (camlint_of_coqint n) - | Omulhs, [r1;r2] -> fprintf pp "mulhs(%a,%a)" reg r1 reg r2 - | Omulhu, [r1;r2] -> fprintf pp "mulhu(%a,%a)" reg r1 reg r2 - | Odiv, [r1;r2] -> fprintf pp "%a /s %a" reg r1 reg r2 - | Odivu, [r1;r2] -> fprintf pp "%a /u %a" reg r1 reg r2 - | Omod, [r1;r2] -> fprintf pp "%a %%s %a" reg r1 reg r2 - | Omodu, [r1;r2] -> fprintf pp "%a %%u %a" reg r1 reg r2 - | Oand, [r1;r2] -> fprintf pp "%a & %a" reg r1 reg r2 - | Oandimm n, [r1] -> fprintf pp "%a & %ld" reg r1 (camlint_of_coqint n) - | Oor, [r1;r2] -> fprintf pp "%a | %a" reg r1 reg r2 - | Oorimm n, [r1] -> fprintf pp "%a | %ld" reg r1 (camlint_of_coqint n) - | Oxor, [r1;r2] -> fprintf pp "%a ^ %a" reg r1 reg r2 - | Oxorimm n, [r1] -> fprintf pp "%a ^ %ld" reg r1 (camlint_of_coqint n) - | Onot, [r1] -> fprintf pp "not(%a)" reg r1 - | Oshl, [r1;r2] -> fprintf pp "%a << %a" reg r1 reg r2 - | Oshlimm n, [r1] -> fprintf pp "%a << %ld" reg r1 (camlint_of_coqint n) - | Oshr, [r1;r2] -> fprintf pp "%a >>s %a" reg r1 reg r2 - | Oshrimm n, [r1] -> fprintf pp "%a >>s %ld" reg r1 (camlint_of_coqint n) - | Oshrximm n, [r1] -> fprintf pp "%a >>x %ld" reg r1 (camlint_of_coqint n) - | Oshru, [r1;r2] -> fprintf pp "%a >>u %a" reg r1 reg r2 - | Oshruimm n, [r1] -> fprintf pp "%a >>u %ld" reg r1 (camlint_of_coqint n) - | Ororimm n, [r1] -> fprintf pp "%a ror %ld" reg r1 (camlint_of_coqint n) - | Oshldimm n, [r1;r2] -> fprintf pp "(%a, %a) << %ld" reg r1 reg r2 (camlint_of_coqint n) - | Olea addr, args -> print_addressing reg pp (addr, args); fprintf pp " (int)" - | Omakelong, [r1;r2] -> fprintf pp "makelong(%a,%a)" reg r1 reg r2 - | Olowlong, [r1] -> fprintf pp "lowlong(%a)" reg r1 - | Ohighlong, [r1] -> fprintf pp "highlong(%a)" reg r1 - | Ocast32signed, [r1] -> fprintf pp "long32signed(%a)" reg r1 - | Ocast32unsigned, [r1] -> fprintf pp "long32unsigned(%a)" reg r1 - | Onegl, [r1] -> fprintf pp "(-l %a)" reg r1 - | Osubl, [r1;r2] -> fprintf pp "%a -l %a" reg r1 reg r2 - | Omull, [r1;r2] -> fprintf pp "%a *l %a" reg r1 reg r2 - | Omullimm n, [r1] -> fprintf pp "%a *l %Ld" reg r1 (camlint64_of_coqint n) - | Omullhs, [r1;r2] -> fprintf pp "mullhs(%a,%a)" reg r1 reg r2 - | Omullhu, [r1;r2] -> fprintf pp "mullhu(%a,%a)" reg r1 reg r2 - | Odivl, [r1;r2] -> fprintf pp "%a /ls %a" reg r1 reg r2 - | Odivlu, [r1;r2] -> fprintf pp "%a /lu %a" reg r1 reg r2 - | Omodl, [r1;r2] -> fprintf pp "%a %%ls %a" reg r1 reg r2 - | Omodlu, [r1;r2] -> fprintf pp "%a %%lu %a" reg r1 reg r2 - | Oandl, [r1;r2] -> fprintf pp "%a &l %a" reg r1 reg r2 - | Oandlimm n, [r1] -> fprintf pp "%a &l %Ld" reg r1 (camlint64_of_coqint n) - | Oorl, [r1;r2] -> fprintf pp "%a |l %a" reg r1 reg r2 - | Oorlimm n, [r1] -> fprintf pp "%a |l %Ld" reg r1 (camlint64_of_coqint n) - | Oxorl, [r1;r2] -> fprintf pp "%a ^l %a" reg r1 reg r2 - | Oxorlimm n, [r1] -> fprintf pp "%a ^l %Ld" reg r1 (camlint64_of_coqint n) - | Onotl, [r1] -> fprintf pp "notl(%a)" reg r1 - | Oshll, [r1;r2] -> fprintf pp "%a <<l %a" reg r1 reg r2 - | Oshllimm n, [r1] -> fprintf pp "%a <<l %ld" reg r1 (camlint_of_coqint n) - | Oshrl, [r1;r2] -> fprintf pp "%a >>ls %a" reg r1 reg r2 - | Oshrlimm n, [r1] -> fprintf pp "%a >>ls %ld" reg r1 (camlint_of_coqint n) - | Oshrxlimm n, [r1] -> fprintf pp "%a >>lx %ld" reg r1 (camlint_of_coqint n) - | Oshrlu, [r1;r2] -> fprintf pp "%a >>lu %a" reg r1 reg r2 - | Oshrluimm n, [r1] -> fprintf pp "%a >>lu %ld" reg r1 (camlint_of_coqint n) - | Ororlimm n, [r1] -> fprintf pp "%a rorl %ld" reg r1 (camlint_of_coqint n) - | Oleal addr, args -> print_addressing reg pp (addr, args); fprintf pp " (long)" - | Onegf, [r1] -> fprintf pp "negf(%a)" reg r1 - | Oabsf, [r1] -> fprintf pp "absf(%a)" reg r1 - | Oaddf, [r1;r2] -> fprintf pp "%a +f %a" reg r1 reg r2 - | Osubf, [r1;r2] -> fprintf pp "%a -f %a" reg r1 reg r2 - | Omulf, [r1;r2] -> fprintf pp "%a *f %a" reg r1 reg r2 - | Odivf, [r1;r2] -> fprintf pp "%a /f %a" reg r1 reg r2 - | Onegfs, [r1] -> fprintf pp "negfs(%a)" reg r1 - | Oabsfs, [r1] -> fprintf pp "absfs(%a)" reg r1 - | Oaddfs, [r1;r2] -> fprintf pp "%a +fs %a" reg r1 reg r2 - | Osubfs, [r1;r2] -> fprintf pp "%a -fs %a" reg r1 reg r2 - | Omulfs, [r1;r2] -> fprintf pp "%a *fs %a" reg r1 reg r2 - | Odivfs, [r1;r2] -> fprintf pp "%a /fs %a" reg r1 reg r2 - | Osingleoffloat, [r1] -> fprintf pp "singleoffloat(%a)" reg r1 - | Ofloatofsingle, [r1] -> fprintf pp "floatofsingle(%a)" reg r1 - | Ointoffloat, [r1] -> fprintf pp "intoffloat(%a)" reg r1 - | Ofloatofint, [r1] -> fprintf pp "floatofint(%a)" reg r1 - | Ointofsingle, [r1] -> fprintf pp "intofsingle(%a)" reg r1 - | Osingleofint, [r1] -> fprintf pp "singleofint(%a)" reg r1 - | Olongoffloat, [r1] -> fprintf pp "longoffloat(%a)" reg r1 - | Ofloatoflong, [r1] -> fprintf pp "floatoflong(%a)" reg r1 - | Olongofsingle, [r1] -> fprintf pp "longofsingle(%a)" reg r1 - | Osingleoflong, [r1] -> fprintf pp "singleoflong(%a)" reg r1 - | Ocmp c, args -> print_condition reg pp (c, args) - | _ -> fprintf pp "<bad operator>" - - diff --git a/ia32/SelectLong.vp b/ia32/SelectLong.vp deleted file mode 100644 index b213e23f..00000000 --- a/ia32/SelectLong.vp +++ /dev/null @@ -1,347 +0,0 @@ -(* *********************************************************************) -(* *) -(* 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/ia32/SelectLongproof.v b/ia32/SelectLongproof.v deleted file mode 100644 index a3d2bb19..00000000 --- a/ia32/SelectLongproof.v +++ /dev/null @@ -1,557 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Correctness of instruction selection for 64-bit integer operations *) - -Require Import String Coqlib Maps Integers Floats Errors. -Require Archi. -Require Import AST Values Memory Globalenvs Events. -Require Import Cminor Op CminorSel. -Require Import SelectOp SelectOpproof SplitLong SplitLongproof. -Require Import SelectLong. - -Open Local Scope cminorsel_scope. -Open Local Scope string_scope. - -(** * Correctness of the instruction selection functions for 64-bit operators *) - -Section CMCONSTR. - -Variable prog: program. -Variable hf: helper_functions. -Hypothesis HELPERS: helper_functions_declared prog hf. -Let ge := Genv.globalenv prog. -Variable sp: val. -Variable e: env. -Variable m: mem. - -Definition unary_constructor_sound (cstr: expr -> expr) (sem: val -> val) : Prop := - forall le a x, - eval_expr ge sp e m le a x -> - exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef (sem x) v. - -Definition binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> val) : Prop := - forall le a x b y, - eval_expr ge sp e m le a x -> - eval_expr ge sp e m le b y -> - exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef (sem x y) v. - -Definition partial_unary_constructor_sound (cstr: expr -> expr) (sem: val -> option val) : Prop := - forall le a x y, - eval_expr ge sp e m le a x -> - sem x = Some y -> - exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef y v. - -Definition partial_binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> option val) : Prop := - forall le a x b y z, - eval_expr ge sp e m le a x -> - eval_expr ge sp e m le b y -> - sem x y = Some z -> - exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef z v. - -Theorem eval_longconst: - forall le n, eval_expr ge sp e m le (longconst n) (Vlong n). -Proof. - unfold longconst; intros; destruct Archi.splitlong. - apply SplitLongproof.eval_longconst. - EvalOp. -Qed. - -Lemma is_longconst_sound: - forall v a n le, - is_longconst a = Some n -> eval_expr ge sp e m le a v -> v = Vlong n. -Proof with (try discriminate). - intros. unfold is_longconst in *. destruct Archi.splitlong. - eapply SplitLongproof.is_longconst_sound; eauto. - assert (a = Eop (Olongconst n) Enil). - { destruct a... destruct o... destruct e0... congruence. } - subst a. InvEval. auto. -Qed. - -Theorem eval_intoflong: unary_constructor_sound intoflong Val.loword. -Proof. - unfold intoflong; destruct Archi.splitlong. apply SplitLongproof.eval_intoflong. - red; intros. destruct (is_longconst a) as [n|] eqn:C. -- TrivialExists. simpl. erewrite (is_longconst_sound x) by eauto. auto. -- TrivialExists. -Qed. - -Theorem eval_longofintu: unary_constructor_sound longofintu Val.longofintu. -Proof. - unfold longofintu; destruct Archi.splitlong. apply SplitLongproof.eval_longofintu. - red; intros. destruct (is_intconst a) as [n|] eqn:C. -- econstructor; split. apply eval_longconst. - exploit is_intconst_sound; eauto. intros; subst x. auto. -- TrivialExists. -Qed. - -Theorem eval_longofint: unary_constructor_sound longofint Val.longofint. -Proof. - unfold longofint; destruct Archi.splitlong. apply SplitLongproof.eval_longofint. - red; intros. destruct (is_intconst a) as [n|] eqn:C. -- econstructor; split. apply eval_longconst. - exploit is_intconst_sound; eauto. intros; subst x. auto. -- TrivialExists. -Qed. - -Theorem eval_notl: unary_constructor_sound notl Val.notl. -Proof. - unfold notl; destruct Archi.splitlong. apply SplitLongproof.eval_notl. - red; intros. destruct (notl_match a). -- InvEval. econstructor; split. apply eval_longconst. auto. -- InvEval. subst. exists v1; split; auto. destruct v1; simpl; auto. rewrite Int64.not_involutive; auto. -- TrivialExists. -Qed. - -Theorem eval_andlimm: forall n, unary_constructor_sound (andlimm n) (fun v => Val.andl v (Vlong n)). -Proof. - unfold andlimm; intros; red; intros. - predSpec Int64.eq Int64.eq_spec n Int64.zero. - exists (Vlong Int64.zero); split. apply eval_longconst. - subst. destruct x; simpl; auto. rewrite Int64.and_zero; auto. - predSpec Int64.eq Int64.eq_spec n Int64.mone. - exists x; split. assumption. - subst. destruct x; simpl; auto. rewrite Int64.and_mone; auto. - destruct (andlimm_match a); InvEval; subst. -- econstructor; split. apply eval_longconst. simpl. rewrite Int64.and_commut; auto. -- TrivialExists. simpl. rewrite Val.andl_assoc. rewrite Int64.and_commut; auto. -- TrivialExists. -Qed. - -Theorem eval_andl: binary_constructor_sound andl Val.andl. -Proof. - unfold andl; destruct Archi.splitlong. apply SplitLongproof.eval_andl. - red; intros. destruct (andl_match a b). -- InvEval. rewrite Val.andl_commut. apply eval_andlimm; auto. -- InvEval. apply eval_andlimm; auto. -- TrivialExists. -Qed. - -Theorem eval_orlimm: forall n, unary_constructor_sound (orlimm n) (fun v => Val.orl v (Vlong n)). -Proof. - unfold orlimm; intros; red; intros. - predSpec Int64.eq Int64.eq_spec n Int64.zero. - exists x; split; auto. subst. destruct x; simpl; auto. rewrite Int64.or_zero; auto. - predSpec Int64.eq Int64.eq_spec n Int64.mone. - econstructor; split. apply eval_longconst. subst. destruct x; simpl; auto. rewrite Int64.or_mone; auto. - destruct (orlimm_match a); InvEval; subst. -- econstructor; split. apply eval_longconst. simpl. rewrite Int64.or_commut; auto. -- TrivialExists. simpl. rewrite Val.orl_assoc. rewrite Int64.or_commut; auto. -- TrivialExists. -Qed. - -Theorem eval_orl: binary_constructor_sound orl Val.orl. -Proof. - unfold orl; destruct Archi.splitlong. apply SplitLongproof.eval_orl. - red; intros. - assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop Oorl (a:::b:::Enil)) v /\ Val.lessdef (Val.orl x y) v) by TrivialExists. - assert (ROR: forall v n1 n2, - Int.add n1 n2 = Int64.iwordsize' -> - Val.lessdef (Val.orl (Val.shll v (Vint n1)) (Val.shrlu v (Vint n2))) - (Val.rorl v (Vint n2))). - { intros. destruct v; simpl; auto. - destruct (Int.ltu n1 Int64.iwordsize') eqn:N1; auto. - destruct (Int.ltu n2 Int64.iwordsize') eqn:N2; auto. - simpl. rewrite <- Int64.or_ror'; auto. } - destruct (orl_match a b). -- InvEval. rewrite Val.orl_commut. apply eval_orlimm; auto. -- InvEval. apply eval_orlimm; auto. -- predSpec Int.eq Int.eq_spec (Int.add n1 n2) Int64.iwordsize'; auto. - destruct (same_expr_pure t1 t2) eqn:?; auto. - InvEval. exploit eval_same_expr; eauto. intros [EQ1 EQ2]; subst. - exists (Val.rorl v0 (Vint n2)); split. EvalOp. apply ROR; auto. -- predSpec Int.eq Int.eq_spec (Int.add n1 n2) Int64.iwordsize'; auto. - destruct (same_expr_pure t1 t2) eqn:?; auto. - InvEval. exploit eval_same_expr; eauto. intros [EQ1 EQ2]; subst. - exists (Val.rorl v1 (Vint n2)); split. EvalOp. rewrite Val.orl_commut. apply ROR; auto. -- apply DEFAULT. -Qed. - -Theorem eval_xorlimm: forall n, unary_constructor_sound (xorlimm n) (fun v => Val.xorl v (Vlong n)). -Proof. - unfold xorlimm; intros; red; intros. - predSpec Int64.eq Int64.eq_spec n Int64.zero. - exists x; split; auto. subst. destruct x; simpl; auto. rewrite Int64.xor_zero; auto. - predSpec Int64.eq Int64.eq_spec n Int64.mone. - replace (Val.xorl x (Vlong n)) with (Val.notl x). apply eval_notl; auto. - subst n. destruct x; simpl; auto. - destruct (xorlimm_match a); InvEval; subst. -- econstructor; split. apply eval_longconst. simpl. rewrite Int64.xor_commut; auto. -- TrivialExists. simpl. rewrite Val.xorl_assoc. rewrite Int64.xor_commut; auto. -- TrivialExists. simpl. destruct v1; simpl; auto. unfold Int64.not. - rewrite Int64.xor_assoc. apply f_equal. apply f_equal. apply f_equal. - apply Int64.xor_commut. -- TrivialExists. -Qed. - -Theorem eval_xorl: binary_constructor_sound xorl Val.xorl. -Proof. - unfold xorl; destruct Archi.splitlong. apply SplitLongproof.eval_xorl. - red; intros. destruct (xorl_match a b). -- InvEval. rewrite Val.xorl_commut. apply eval_xorlimm; auto. -- InvEval. apply eval_xorlimm; auto. -- TrivialExists. -Qed. - -Theorem eval_shllimm: forall n, unary_constructor_sound (fun e => shllimm e n) (fun v => Val.shll v (Vint n)). -Proof. - intros; unfold shllimm. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shllimm; auto. - red; intros. - predSpec Int.eq Int.eq_spec n Int.zero. - exists x; split; auto. subst n; destruct x; simpl; auto. - destruct (Int.ltu Int.zero Int64.iwordsize'); auto. - change (Int64.shl' i Int.zero) with (Int64.shl i Int64.zero). rewrite Int64.shl_zero; auto. - destruct (Int.ltu n Int64.iwordsize') eqn:LT; simpl. - assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop (Oshllimm n) (a:::Enil)) v - /\ Val.lessdef (Val.shll x (Vint n)) v) by TrivialExists. - destruct (shllimm_match a); InvEval. -- TrivialExists. simpl; rewrite LT; auto. -- destruct (Int.ltu (Int.add n n1) Int64.iwordsize') eqn:LT'; auto. - subst. econstructor; split. EvalOp. simpl; eauto. - destruct v1; simpl; auto. rewrite LT'. - destruct (Int.ltu n1 Int64.iwordsize') eqn:LT1; auto. - simpl; rewrite LT. rewrite Int.add_commut, Int64.shl'_shl'; auto. rewrite Int.add_commut; auto. -- destruct (shift_is_scale n); auto. - TrivialExists. simpl. subst x. 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 Archi.ptr64; reflexivity. -- 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; auto. - rewrite Int64.add_zero; auto. - destruct Archi.ptr64; auto. rewrite 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. destruct x; destruct y; simpl; auto. - rewrite Int64.add_zero; auto. - destruct Archi.ptr64 eqn:SF; simpl; auto. rewrite SF. rewrite Ptrofs.add_assoc, Ptrofs.add_zero. auto. - destruct Archi.ptr64 eqn:SF; simpl; auto. rewrite SF. rewrite Ptrofs.add_assoc, Ptrofs.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. subst x. - 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. - destruct Archi.ptr64; 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. apply Archi.splitlong_ptr32; auto. -+ 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. apply Archi.splitlong_ptr32; auto. - 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/ia32/SelectOp.vp b/ia32/SelectOp.vp deleted file mode 100644 index db546d99..00000000 --- a/ia32/SelectOp.vp +++ /dev/null @@ -1,530 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Instruction selection for operators *) - -(** The instruction selection pass recognizes opportunities for using - combined arithmetic and logical operations and addressing modes - offered by the target processor. For instance, the expression [x + 1] - can take advantage of the "immediate add" instruction of the processor, - and on the PowerPC, the expression [(x >> 6) & 0xFF] can be turned - into a "rotate and mask" instruction. - - This file defines functions for building CminorSel expressions and - statements, especially expressions consisting of operator - applications. These functions examine their arguments to choose - cheaper forms of operators whenever possible. - - For instance, [add e1 e2] will return a CminorSel expression semantically - equivalent to [Eop Oadd (e1 ::: e2 ::: Enil)], but will use a - [Oaddimm] operator if one of the arguments is an integer constant, - or suppress the addition altogether if one of the arguments is the - null integer. In passing, we perform operator reassociation - ([(e + c1) * c2] becomes [(e * c2) + (c1 * c2)]) and a small amount - of constant propagation. - - On top of the "smart constructor" functions defined below, - module [Selection] implements the actual instruction selection pass. -*) - -Require Import Coqlib. -Require Import Compopts. -Require Import AST Integers Floats. -Require Import Op CminorSel. - -Open Local Scope cminorsel_scope. - -(** ** Constants **) - -(** External oracle to determine whether a symbol should be addressed - through [Oindirectsymbol] or can be addressed via [Oleal Aglobal]. - This is to accommodate MacOS X's limitations on references to data - symbols imported from shared libraries. It can also help with PIC - code under ELF. *) - -Parameter symbol_is_external: ident -> bool. - -Definition Olea_ptr (a: addressing) := if Archi.ptr64 then Oleal a else Olea a. - -Definition addrsymbol (id: ident) (ofs: ptrofs) := - if symbol_is_external id then - if Ptrofs.eq ofs Ptrofs.zero - then Eop (Oindirectsymbol id) Enil - else Eop (Olea_ptr (Aindexed (Ptrofs.unsigned ofs))) (Eop (Oindirectsymbol id) Enil ::: Enil) - else - Eop (Olea_ptr (Aglobal id ofs)) Enil. - -Definition addrstack (ofs: ptrofs) := - Eop (Olea_ptr (Ainstack ofs)) Enil. - -(** ** Integer logical negation *) - -Nondetfunction notint (e: expr) := - match e with - | Eop (Ointconst n) Enil => Eop (Ointconst (Int.not n)) Enil - | Eop (Oxorimm n) (e1 ::: Enil) => Eop (Oxorimm (Int.not n)) (e1 ::: Enil) - | _ => Eop Onot (e ::: Enil) - end. - -(** ** Integer addition and pointer addition *) - -Nondetfunction addimm (n: int) (e: expr) := - if Int.eq n Int.zero then e else - match e with - | Eop (Ointconst m) Enil => Eop (Ointconst(Int.add n m)) Enil - | Eop (Olea addr) args => Eop (Olea (offset_addressing_total addr (Int.signed n))) args - | _ => Eop (Olea (Aindexed (Int.signed n))) (e ::: Enil) - end. - -Nondetfunction add (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => addimm n1 t2 - | t1, Eop (Ointconst n2) Enil => addimm n2 t1 - | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => - Eop (Olea (Aindexed2 (n1 + n2))) (t1:::t2:::Enil) - | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Ascaled sc n2)) (t2:::Enil) => - Eop (Olea (Aindexed2scaled sc (n1 + n2))) (t1:::t2:::Enil) - | Eop (Olea (Ascaled sc n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => - Eop (Olea (Aindexed2scaled sc (n1 + n2))) (t2:::t1:::Enil) - | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aglobal id ofs)) Enil => - Eop (Olea (Abased id (Ptrofs.add ofs (Ptrofs.repr n1)))) (t1:::Enil) - | Eop (Olea (Aglobal id ofs)) Enil, Eop (Olea (Aindexed n2)) (t2:::Enil) => - Eop (Olea (Abased id (Ptrofs.add ofs (Ptrofs.repr n2)))) (t2:::Enil) - | Eop (Olea (Ascaled sc n1)) (t1:::Enil), Eop (Olea (Aglobal id ofs)) Enil => - Eop (Olea (Abasedscaled sc id (Ptrofs.add ofs (Ptrofs.repr n1)))) (t1:::Enil) - | Eop (Olea (Aglobal id ofs)) Enil, Eop (Olea (Ascaled sc n2)) (t2:::Enil) => - Eop (Olea (Abasedscaled sc id (Ptrofs.add ofs (Ptrofs.repr n2)))) (t2:::Enil) - | Eop (Olea (Ascaled sc n)) (t1:::Enil), t2 => - Eop (Olea (Aindexed2scaled sc n)) (t2:::t1:::Enil) - | t1, Eop (Olea (Ascaled sc n)) (t2:::Enil) => - Eop (Olea (Aindexed2scaled sc n)) (t1:::t2:::Enil) - | Eop (Olea (Aindexed n)) (t1:::Enil), t2 => - Eop (Olea (Aindexed2 n)) (t1:::t2:::Enil) - | t1, Eop (Olea (Aindexed n)) (t2:::Enil) => - Eop (Olea (Aindexed2 n)) (t1:::t2:::Enil) - | _, _ => - Eop (Olea (Aindexed2 0)) (e1:::e2:::Enil) - end. - -(** ** Opposite *) - -Nondetfunction negint (e: expr) := - match e with - | Eop (Ointconst n) Enil => Eop (Ointconst (Int.neg n)) Enil - | _ => Eop Oneg (e ::: Enil) - end. - -(** ** Integer and pointer subtraction *) - -Nondetfunction sub (e1: expr) (e2: expr) := - match e1, e2 with - | t1, Eop (Ointconst n2) Enil => addimm (Int.neg n2) t1 - | Eop (Olea (Aindexed n1)) (t1:::Enil), Eop (Olea (Aindexed n2)) (t2:::Enil) => - addimm (Int.repr (n1 - n2)) (Eop Osub (t1:::t2:::Enil)) - | Eop (Olea (Aindexed n1)) (t1:::Enil), t2 => - addimm (Int.repr n1) (Eop Osub (t1:::t2:::Enil)) - | t1, Eop (Olea (Aindexed n2)) (t2:::Enil) => - addimm (Int.repr (-n2)) (Eop Osub (t1:::t2:::Enil)) - | _, _ => - Eop Osub (e1:::e2:::Enil) - end. - -(** ** Immediate shifts *) - -Definition shift_is_scale (n: int) : bool := - Int.eq n (Int.repr 1) || Int.eq n (Int.repr 2) || Int.eq n (Int.repr 3). - -Nondetfunction shlimm (e1: expr) (n: int) := - if Int.eq n Int.zero then e1 else - if negb (Int.ltu n Int.iwordsize) then - Eop Oshl (e1:::Eop (Ointconst n) Enil:::Enil) - else - match e1 with - | Eop (Ointconst n1) Enil => - Eop (Ointconst(Int.shl n1 n)) Enil - | Eop (Oshlimm n1) (t1:::Enil) => - if Int.ltu (Int.add n n1) Int.iwordsize - then Eop (Oshlimm (Int.add n n1)) (t1:::Enil) - else Eop (Oshlimm n) (e1:::Enil) - | Eop (Olea (Aindexed n1)) (t1:::Enil) => - if shift_is_scale n - then Eop (Olea (Ascaled (Int.unsigned (Int.shl Int.one n)) - (Int.unsigned (Int.shl (Int.repr n1) n)))) (t1:::Enil) - else Eop (Oshlimm n) (e1:::Enil) - | _ => - if shift_is_scale n - then Eop (Olea (Ascaled (Int.unsigned (Int.shl Int.one n)) 0)) (e1:::Enil) - else Eop (Oshlimm n) (e1:::Enil) - end. - -Nondetfunction shruimm (e1: expr) (n: int) := - if Int.eq n Int.zero then e1 else - if negb (Int.ltu n Int.iwordsize) then - Eop Oshru (e1:::Eop (Ointconst n) Enil:::Enil) - else - match e1 with - | Eop (Ointconst n1) Enil => - Eop (Ointconst(Int.shru n1 n)) Enil - | Eop (Oshruimm n1) (t1:::Enil) => - if Int.ltu (Int.add n n1) Int.iwordsize - then Eop (Oshruimm (Int.add n n1)) (t1:::Enil) - else Eop (Oshruimm n) (e1:::Enil) - | _ => - Eop (Oshruimm n) (e1:::Enil) - end. - -Nondetfunction shrimm (e1: expr) (n: int) := - if Int.eq n Int.zero then e1 else - if negb (Int.ltu n Int.iwordsize) then - Eop Oshr (e1:::Eop (Ointconst n) Enil:::Enil) - else - match e1 with - | Eop (Ointconst n1) Enil => - Eop (Ointconst(Int.shr n1 n)) Enil - | Eop (Oshrimm n1) (t1:::Enil) => - if Int.ltu (Int.add n n1) Int.iwordsize - then Eop (Oshrimm (Int.add n n1)) (t1:::Enil) - else Eop (Oshrimm n) (e1:::Enil) - | _ => - Eop (Oshrimm n) (e1:::Enil) - end. - -(** ** Integer multiply *) - -Definition mulimm_base (n1: int) (e2: expr) := - match Int.one_bits n1 with - | i :: nil => - shlimm e2 i - | i :: j :: nil => - Elet e2 (add (shlimm (Eletvar 0) i) (shlimm (Eletvar 0) j)) - | _ => - Eop (Omulimm n1) (e2:::Enil) - end. - -Nondetfunction mulimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil - else if Int.eq n1 Int.one then e2 - else match e2 with - | Eop (Ointconst n2) Enil => Eop (Ointconst(Int.mul n1 n2)) Enil - | Eop (Olea (Aindexed n2)) (t2:::Enil) => addimm (Int.mul n1 (Int.repr n2)) (mulimm_base n1 t2) - | _ => mulimm_base n1 e2 - end. - -Nondetfunction mul (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => mulimm n1 t2 - | t1, Eop (Ointconst n2) Enil => mulimm n2 t1 - | _, _ => Eop Omul (e1:::e2:::Enil) - end. - -(** ** Bitwise and, or, xor *) - -Nondetfunction andimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil - else if Int.eq n1 Int.mone then e2 - else match e2 with - | Eop (Ointconst n2) Enil => - Eop (Ointconst (Int.and n1 n2)) Enil - | Eop (Oandimm n2) (t2:::Enil) => - Eop (Oandimm (Int.and n1 n2)) (t2:::Enil) - | Eop Ocast8unsigned (t2:::Enil) => - Eop (Oandimm (Int.and n1 (Int.repr 255))) (t2:::Enil) - | Eop Ocast16unsigned (t2:::Enil) => - Eop (Oandimm (Int.and n1 (Int.repr 65535))) (t2:::Enil) - | _ => - Eop (Oandimm n1) (e2:::Enil) - end. - -Nondetfunction and (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => andimm n1 t2 - | t1, Eop (Ointconst n2) Enil => andimm n2 t1 - | _, _ => Eop Oand (e1:::e2:::Enil) - end. - -Nondetfunction orimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then e2 - else if Int.eq n1 Int.mone then Eop (Ointconst Int.mone) Enil - else match e2 with - | Eop (Ointconst n2) Enil => - Eop (Ointconst (Int.or n1 n2)) Enil - | Eop (Oorimm n2) (t2:::Enil) => - Eop (Oorimm (Int.or n1 n2)) (t2:::Enil) - | _ => - Eop (Oorimm n1) (e2:::Enil) - end. - -Definition same_expr_pure (e1 e2: expr) := - match e1, e2 with - | Evar v1, Evar v2 => if ident_eq v1 v2 then true else false - | _, _ => false - end. - -Nondetfunction or (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => orimm n1 t2 - | t1, Eop (Ointconst n2) Enil => orimm n2 t1 - | Eop (Oshlimm n1) (t1:::Enil), Eop (Oshruimm n2) (t2:::Enil) => - if Int.eq (Int.add n1 n2) Int.iwordsize then - if same_expr_pure t1 t2 - then Eop (Ororimm n2) (t1:::Enil) - else Eop (Oshldimm n1) (t1:::t2:::Enil) - else Eop Oor (e1:::e2:::Enil) - | Eop (Oshruimm n2) (t2:::Enil), Eop (Oshlimm n1) (t1:::Enil) => - if Int.eq (Int.add n1 n2) Int.iwordsize then - if same_expr_pure t1 t2 - then Eop (Ororimm n2) (t1:::Enil) - else Eop (Oshldimm n1) (t1:::t2:::Enil) - else Eop Oor (e1:::e2:::Enil) - | _, _ => - Eop Oor (e1:::e2:::Enil) - end. - -Nondetfunction xorimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then e2 - else match e2 with - | Eop (Ointconst n2) Enil => - Eop (Ointconst (Int.xor n1 n2)) Enil - | Eop (Oxorimm n2) (t2:::Enil) => - Eop (Oxorimm (Int.xor n1 n2)) (t2:::Enil) - | Eop Onot (t2:::Enil) => - Eop (Oxorimm (Int.not n1)) (t2:::Enil) - | _ => - Eop (Oxorimm n1) (e2:::Enil) - end. - -Nondetfunction xor (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => xorimm n1 t2 - | t1, Eop (Ointconst n2) Enil => xorimm n2 t1 - | _, _ => Eop Oxor (e1:::e2:::Enil) - end. - -(** ** Integer division and modulus *) - -Definition divu_base (e1: expr) (e2: expr) := Eop Odivu (e1:::e2:::Enil). -Definition modu_base (e1: expr) (e2: expr) := Eop Omodu (e1:::e2:::Enil). -Definition divs_base (e1: expr) (e2: expr) := Eop Odiv (e1:::e2:::Enil). -Definition mods_base (e1: expr) (e2: expr) := Eop Omod (e1:::e2:::Enil). - -Definition shrximm (e1: expr) (n2: int) := - if Int.eq n2 Int.zero then e1 else Eop (Oshrximm n2) (e1:::Enil). - -(** ** General shifts *) - -Nondetfunction shl (e1: expr) (e2: expr) := - match e2 with - | Eop (Ointconst n2) Enil => shlimm e1 n2 - | _ => Eop Oshl (e1:::e2:::Enil) - end. - -Nondetfunction shr (e1: expr) (e2: expr) := - match e2 with - | Eop (Ointconst n2) Enil => shrimm e1 n2 - | _ => Eop Oshr (e1:::e2:::Enil) - end. - -Nondetfunction shru (e1: expr) (e2: expr) := - match e2 with - | Eop (Ointconst n2) Enil => shruimm e1 n2 - | _ => Eop Oshru (e1:::e2:::Enil) - end. - -(** ** Floating-point arithmetic *) - -Definition negf (e: expr) := Eop Onegf (e ::: Enil). -Definition absf (e: expr) := Eop Oabsf (e ::: Enil). -Definition addf (e1 e2: expr) := Eop Oaddf (e1 ::: e2 ::: Enil). -Definition subf (e1 e2: expr) := Eop Osubf (e1 ::: e2 ::: Enil). -Definition mulf (e1 e2: expr) := Eop Omulf (e1 ::: e2 ::: Enil). - -Definition negfs (e: expr) := Eop Onegfs (e ::: Enil). -Definition absfs (e: expr) := Eop Oabsfs (e ::: Enil). -Definition addfs (e1 e2: expr) := Eop Oaddfs (e1 ::: e2 ::: Enil). -Definition subfs (e1 e2: expr) := Eop Osubfs (e1 ::: e2 ::: Enil). -Definition mulfs (e1 e2: expr) := Eop Omulfs (e1 ::: e2 ::: Enil). - -(** ** Comparisons *) - -Nondetfunction compimm (default: comparison -> int -> condition) - (sem: comparison -> int -> int -> bool) - (c: comparison) (e1: expr) (n2: int) := - match c, e1 with - | c, Eop (Ointconst n1) Enil => - Eop (Ointconst (if sem c n1 n2 then Int.one else Int.zero)) Enil - | Ceq, Eop (Ocmp c) el => - if Int.eq_dec n2 Int.zero then - Eop (Ocmp (negate_condition c)) el - else if Int.eq_dec n2 Int.one then - Eop (Ocmp c) el - else - Eop (Ointconst Int.zero) Enil - | Cne, Eop (Ocmp c) el => - if Int.eq_dec n2 Int.zero then - Eop (Ocmp c) el - else if Int.eq_dec n2 Int.one then - Eop (Ocmp (negate_condition c)) el - else - Eop (Ointconst Int.one) Enil - | Ceq, Eop (Oandimm n1) (t1 ::: Enil) => - if Int.eq_dec n2 Int.zero then - Eop (Ocmp (Cmaskzero n1)) (t1 ::: Enil) - else - Eop (Ocmp (default c n2)) (e1 ::: Enil) - | Cne, Eop (Oandimm n1) (t1 ::: Enil) => - if Int.eq_dec n2 Int.zero then - Eop (Ocmp (Cmasknotzero n1)) (t1 ::: Enil) - else - Eop (Ocmp (default c n2)) (e1 ::: Enil) - | _, _ => - Eop (Ocmp (default c n2)) (e1 ::: Enil) - end. - -Nondetfunction comp (c: comparison) (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => - compimm Ccompimm Int.cmp (swap_comparison c) t2 n1 - | t1, Eop (Ointconst n2) Enil => - compimm Ccompimm Int.cmp c t1 n2 - | _, _ => - Eop (Ocmp (Ccomp c)) (e1 ::: e2 ::: Enil) - end. - -Nondetfunction compu (c: comparison) (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => - compimm Ccompuimm Int.cmpu (swap_comparison c) t2 n1 - | t1, Eop (Ointconst n2) Enil => - compimm Ccompuimm Int.cmpu c t1 n2 - | _, _ => - Eop (Ocmp (Ccompu c)) (e1 ::: e2 ::: Enil) - end. - -Definition compf (c: comparison) (e1: expr) (e2: expr) := - Eop (Ocmp (Ccompf c)) (e1 ::: e2 ::: Enil). - -Definition compfs (c: comparison) (e1: expr) (e2: expr) := - Eop (Ocmp (Ccompfs c)) (e1 ::: e2 ::: Enil). - -(** ** Integer conversions *) - -Nondetfunction cast8unsigned (e: expr) := - match e with - | Eop (Ointconst n) Enil => - Eop (Ointconst (Int.zero_ext 8 n)) Enil - | Eop (Oandimm n) (t:::Enil) => - andimm (Int.and (Int.repr 255) n) t - | _ => - Eop Ocast8unsigned (e:::Enil) - end. - -Nondetfunction cast8signed (e: expr) := - match e with - | Eop (Ointconst n) Enil => - Eop (Ointconst (Int.sign_ext 8 n)) Enil - | _ => - Eop Ocast8signed (e ::: Enil) - end. - -Nondetfunction cast16unsigned (e: expr) := - match e with - | Eop (Ointconst n) Enil => - Eop (Ointconst (Int.zero_ext 16 n)) Enil - | Eop (Oandimm n) (t:::Enil) => - andimm (Int.and (Int.repr 65535) n) t - | _ => - Eop Ocast16unsigned (e:::Enil) - end. - -Nondetfunction cast16signed (e: expr) := - match e with - | Eop (Ointconst n) Enil => - Eop (Ointconst (Int.sign_ext 16 n)) Enil - | _ => - Eop Ocast16signed (e ::: Enil) - end. - -(** Floating-point conversions *) - -Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil). -Definition floatofsingle (e: expr) := Eop Ofloatofsingle (e ::: Enil). - -Definition intoffloat (e: expr) := Eop Ointoffloat (e ::: Enil). - -Nondetfunction floatofint (e: expr) := - match e with - | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_int n)) Enil - | _ => Eop Ofloatofint (e ::: Enil) - end. - -Definition intuoffloat (e: expr) := - Elet e - (Elet (Eop (Ofloatconst (Float.of_intu Float.ox8000_0000)) Enil) - (Econdition (CEcond (Ccompf Clt) (Eletvar 1 ::: Eletvar 0 ::: Enil)) - (intoffloat (Eletvar 1)) - (addimm Float.ox8000_0000 (intoffloat (subf (Eletvar 1) (Eletvar 0))))))%nat. - -Nondetfunction floatofintu (e: expr) := - match e with - | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_intu n)) Enil - | _ => - let f := Eop (Ofloatconst (Float.of_intu Float.ox8000_0000)) Enil in - Elet e - (Econdition (CEcond (Ccompuimm Clt Float.ox8000_0000) (Eletvar O ::: Enil)) - (floatofint (Eletvar O)) - (addf (floatofint (addimm (Int.neg Float.ox8000_0000) (Eletvar O))) f)) - end. - -Definition intofsingle (e: expr) := Eop Ointofsingle (e ::: Enil). - -Nondetfunction singleofint (e: expr) := - match e with - | Eop (Ointconst n) Enil => Eop (Osingleconst (Float32.of_int n)) Enil - | _ => Eop Osingleofint (e ::: Enil) - end. - -Definition intuofsingle (e: expr) := intuoffloat (floatofsingle e). - -Nondetfunction singleofintu (e: expr) := - match e with - | Eop (Ointconst n) Enil => Eop (Osingleconst (Float32.of_intu n)) Enil - | _ => singleoffloat (floatofintu e) - end. - -(** ** Addressing modes *) - -Nondetfunction addressing (chunk: memory_chunk) (e: expr) := - match e with - | Eop (Olea addr) args => - if (negb Archi.ptr64) && addressing_valid addr then (addr, args) else (Aindexed 0, e:::Enil) - | Eop (Oleal addr) args => - if Archi.ptr64 && addressing_valid addr then (addr, args) else (Aindexed 0, e:::Enil) - | _ => (Aindexed 0, e:::Enil) - end. - -(** ** Arguments of builtins *) - -Nondetfunction builtin_arg (e: expr) := - match e with - | Eop (Ointconst n) Enil => BA_int n - | Eop (Olongconst n) Enil => BA_long n - | Eop (Olea (Aglobal id ofs)) Enil => if Archi.ptr64 then BA e else BA_addrglobal id ofs - | Eop (Olea (Ainstack ofs)) Enil => if Archi.ptr64 then BA e else BA_addrstack ofs - | Eop (Oleal (Aglobal id ofs)) Enil => if Archi.ptr64 then BA_addrglobal id ofs else BA e - | Eop (Oleal (Ainstack ofs)) Enil => if Archi.ptr64 then BA_addrstack ofs else BA e - | Eop Omakelong (Eop (Ointconst h) Enil ::: Eop (Ointconst l) Enil ::: Enil) => - BA_long (Int64.ofwords h l) - | Eop Omakelong (h ::: l ::: Enil) => BA_splitlong (BA h) (BA l) - | Eload chunk (Aglobal id ofs) Enil => BA_loadglobal chunk id ofs - | Eload chunk (Ainstack ofs) Enil => BA_loadstack chunk ofs - | _ => BA e - end. diff --git a/ia32/SelectOpproof.v b/ia32/SelectOpproof.v deleted file mode 100644 index e201d207..00000000 --- a/ia32/SelectOpproof.v +++ /dev/null @@ -1,958 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Correctness of instruction selection for operators *) - -Require Import Coqlib. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Cminor. -Require Import Op. -Require Import CminorSel. -Require Import SelectOp. - -Open Local Scope cminorsel_scope. -Local Transparent Archi.ptr64. - -(** * 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; inv H - | [ H: (eval_operation _ _ _ (_ :: nil) _ = Some _) |- _ ] => - simpl in H; FuncInv - | [ H: (eval_operation _ _ _ (_ :: _ :: nil) _ = Some _) |- _ ] => - simpl in H; FuncInv - | [ H: (eval_operation _ _ _ (_ :: _ :: _ :: nil) _ = Some _) |- _ ] => - simpl in H; FuncInv - | _ => - idtac - end. - -Ltac InvEval := InvEval1; InvEval2; InvEval2. - -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. - unfold Genv.symbol_address; destruct (Genv.find_symbol ge id); simpl; auto. - rewrite SF. rewrite Ptrofs.add_zero_l. fold (Ptrofs.to_int64 ofs). rewrite Ptrofs.of_int64_to_int64 by auto. auto. - unfold Genv.symbol_address; destruct (Genv.find_symbol ge id); simpl; auto. - rewrite SF. rewrite Ptrofs.add_zero_l. fold (Ptrofs.to_int ofs). rewrite Ptrofs.of_int_to_int by auto. 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. - InvEval. subst x. 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; auto. rewrite Int.add_zero; auto. destruct Archi.ptr64; auto. rewrite Ptrofs.add_zero; auto. - case (addimm_match a); intros; InvEval; simpl. - 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. -- subst. TrivialExists. simpl. rewrite A, Val.add_permut_4. auto. -- subst. TrivialExists. simpl. rewrite A, Val.add_assoc. decEq; decEq. rewrite Val.add_permut. auto. -- subst. TrivialExists. simpl. rewrite A, Val.add_permut_4. rewrite <- Val.add_permut. rewrite <- Val.add_assoc. auto. -- subst. 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. -- subst. TrivialExists. simpl. rewrite Heqb0. rewrite B by auto. rewrite Val.add_assoc. do 2 f_equal. apply Val.add_commut. -- subst. 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. -- subst. 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. -- subst. TrivialExists. simpl. rewrite Val.add_permut. rewrite Val.add_assoc. - decEq; decEq. apply Val.add_commut. -- subst. TrivialExists. -- subst. TrivialExists. simpl. repeat rewrite Val.add_assoc. decEq; decEq. apply Val.add_commut. -- subst. TrivialExists. simpl. rewrite Val.add_assoc; auto. -- TrivialExists. simpl. destruct x; destruct y; simpl; auto. - rewrite Int.add_zero; auto. - destruct Archi.ptr64 eqn:SF; simpl; auto. rewrite SF. rewrite Ptrofs.add_assoc, Ptrofs.add_zero. auto. - destruct Archi.ptr64 eqn:SF; simpl; auto. rewrite SF. 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. - subst. 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. - subst. rewrite Val.sub_add_l. apply eval_addimm; EvalOp. - subst. 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. - subst. 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. - subst. TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. - simpl. auto. - subst. 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. - destruct Archi.ptr64; simpl; 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. - subst. 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. - subst. 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. - subst. rewrite Val.mul_add_distr_l. - exploit eval_mulimm_base; eauto. instantiate (1 := n). intros [v' [A1 B1]]. - exploit (eval_addimm (Int.mul n (Int.repr n2)) le (mulimm_base n t2) v'). auto. intros [v'' [A2 B2]]. - exists v''; split; auto. eapply Val.lessdef_trans. eapply Val.add_lessdef; eauto. - rewrite Val.mul_commut; auto. - apply eval_mulimm_base; auto. -Qed. - -Theorem eval_mul: binary_constructor_sound mul Val.mul. -Proof. - red; intros until y. - unfold mul; case (mul_match a b); intros; InvEval. - rewrite Val.mul_commut. apply eval_mulimm. auto. - apply eval_mulimm. auto. - TrivialExists. -Qed. - -Theorem eval_andimm: - forall n, unary_constructor_sound (andimm n) (fun x => Val.and x (Vint n)). -Proof. - intros; red; intros until x. unfold andimm. - predSpec Int.eq Int.eq_spec n Int.zero. - intros. exists (Vint Int.zero); split. EvalOp. - destruct x; simpl; auto. subst n. rewrite Int.and_zero. auto. - predSpec Int.eq Int.eq_spec n Int.mone. - intros. exists x; split; auto. - destruct x; simpl; auto. subst n. rewrite Int.and_mone. auto. - case (andimm_match a); intros; InvEval. - TrivialExists. simpl. rewrite Int.and_commut; auto. - subst. TrivialExists. simpl. rewrite Val.and_assoc. rewrite Int.and_commut. auto. - subst. rewrite Val.zero_ext_and. TrivialExists. rewrite Val.and_assoc. - rewrite Int.and_commut. auto. compute; auto. - subst. rewrite Val.zero_ext_and. TrivialExists. rewrite Val.and_assoc. - rewrite Int.and_commut. auto. compute; auto. - TrivialExists. -Qed. - -Theorem eval_and: binary_constructor_sound and Val.and. -Proof. - red; intros until y; unfold and; case (and_match a b); intros; InvEval. - rewrite Val.and_commut. apply eval_andimm; auto. - apply eval_andimm; auto. - TrivialExists. -Qed. - -Theorem eval_orimm: - forall n, unary_constructor_sound (orimm n) (fun x => Val.or x (Vint n)). -Proof. - intros; red; intros until x. unfold orimm. - predSpec Int.eq Int.eq_spec n Int.zero. - intros. exists x; split. auto. - destruct x; simpl; auto. subst n. rewrite Int.or_zero. auto. - predSpec Int.eq Int.eq_spec n Int.mone. - intros. exists (Vint Int.mone); split. EvalOp. - destruct x; simpl; auto. subst n. rewrite Int.or_mone. auto. - destruct (orimm_match a); intros; InvEval. - TrivialExists. simpl. rewrite Int.or_commut; auto. - subst. rewrite Val.or_assoc. simpl. rewrite Int.or_commut. TrivialExists. - TrivialExists. -Qed. - -Remark eval_same_expr: - forall a1 a2 le v1 v2, - same_expr_pure a1 a2 = true -> - eval_expr ge sp e m le a1 v1 -> - eval_expr ge sp e m le a2 v2 -> - a1 = a2 /\ v1 = v2. -Proof. - intros until v2. - destruct a1; simpl; try (intros; discriminate). - destruct a2; simpl; try (intros; discriminate). - case (ident_eq i i0); intros. - subst i0. inversion H0. inversion H1. split. auto. congruence. - discriminate. -Qed. - -Remark int_add_sub_eq: - forall x y z, Int.add x y = z -> Int.sub z x = y. -Proof. - intros. subst z. rewrite Int.sub_add_l. rewrite Int.sub_idem. apply Int.add_zero_l. -Qed. - -Lemma eval_or: binary_constructor_sound or Val.or. -Proof. - red; intros until y; unfold or; case (or_match a b); intros. -(* intconst *) - InvEval. rewrite Val.or_commut. apply eval_orimm; auto. - InvEval. apply eval_orimm; auto. -(* shlimm - shruimm *) - predSpec Int.eq Int.eq_spec (Int.add n1 n2) Int.iwordsize. - destruct (same_expr_pure t1 t2) eqn:?. - InvEval. exploit eval_same_expr; eauto. intros [EQ1 EQ2]; subst. - exists (Val.ror v0 (Vint n2)); split. EvalOp. - destruct v0; simpl; auto. - destruct (Int.ltu n1 Int.iwordsize) eqn:?; auto. - destruct (Int.ltu n2 Int.iwordsize) eqn:?; auto. - simpl. rewrite <- Int.or_ror; auto. - InvEval. exists (Val.or x y); split. EvalOp. - simpl. erewrite int_add_sub_eq; eauto. rewrite H0; rewrite H; auto. auto. - 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. exists (Val.or y x); split. EvalOp. - simpl. erewrite int_add_sub_eq; eauto. rewrite H0; rewrite H; auto. - 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. - subst. rewrite Val.xor_assoc. simpl. rewrite Int.xor_commut. TrivialExists. - subst. rewrite Val.not_xor. rewrite Val.xor_assoc. - rewrite (Val.xor_commut (Vint Int.mone)). TrivialExists. - TrivialExists. -Qed. - -Theorem eval_xor: binary_constructor_sound xor Val.xor. -Proof. - red; intros until y; unfold xor; case (xor_match a b); intros; InvEval. - rewrite Val.xor_commut. apply eval_xorimm; auto. - apply eval_xorimm; auto. - TrivialExists. -Qed. - -Theorem eval_divs_base: - forall le a b x y z, - eval_expr ge sp e m le a x -> - eval_expr ge sp e m le b y -> - Val.divs x y = Some z -> - exists v, eval_expr ge sp e m le (divs_base a b) v /\ Val.lessdef z v. -Proof. - intros. unfold divs_base. exists z; split. EvalOp. auto. -Qed. - -Theorem eval_divu_base: - forall le a b x y z, - eval_expr ge sp e m le a x -> - eval_expr ge sp e m le b y -> - Val.divu x y = Some z -> - exists v, eval_expr ge sp e m le (divu_base a b) v /\ Val.lessdef z v. -Proof. - intros. unfold divu_base. exists z; split. EvalOp. auto. -Qed. - -Theorem eval_mods_base: - forall le a b x y z, - eval_expr ge sp e m le a x -> - eval_expr ge sp e m le b y -> - Val.mods x y = Some z -> - exists v, eval_expr ge sp e m le (mods_base a b) v /\ Val.lessdef z v. -Proof. - intros. unfold mods_base. exists z; split. EvalOp. auto. -Qed. - -Theorem eval_modu_base: - forall le a b x y z, - eval_expr ge sp e m le a x -> - eval_expr ge sp e m le b y -> - Val.modu x y = Some z -> - exists v, eval_expr ge sp e m le (modu_base a b) v /\ Val.lessdef z v. -Proof. - intros. unfold modu_base. exists z; split. EvalOp. auto. -Qed. - -Theorem eval_shrximm: - forall le a n x z, - eval_expr ge sp e m le a x -> - Val.shrx x (Vint n) = Some z -> - exists v, eval_expr ge sp e m le (shrximm a n) v /\ Val.lessdef z v. -Proof. - intros. unfold shrximm. - predSpec Int.eq Int.eq_spec n Int.zero. - subst n. exists x; split; auto. - destruct x; simpl in H0; try discriminate. - destruct (Int.ltu Int.zero (Int.repr 31)); inv H0. - replace (Int.shrx i Int.zero) with i. auto. - unfold Int.shrx, Int.divs. rewrite Int.shl_zero. - change (Int.signed Int.one) with 1. rewrite Z.quot_1_r. rewrite Int.repr_signed; auto. - econstructor; split. EvalOp. auto. -Qed. - -Theorem eval_shl: binary_constructor_sound shl Val.shl. -Proof. - red; intros until y; unfold shl; case (shl_match b); intros. - InvEval. apply eval_shlimm; auto. - TrivialExists. -Qed. - -Theorem eval_shr: binary_constructor_sound shr Val.shr. -Proof. - red; intros until y; unfold shr; case (shr_match b); intros. - InvEval. apply eval_shrimm; auto. - TrivialExists. -Qed. - -Theorem eval_shru: binary_constructor_sound shru Val.shru. -Proof. - red; intros until y; unfold shru; case (shru_match b); intros. - InvEval. apply eval_shruimm; auto. - TrivialExists. -Qed. - -Theorem eval_negf: unary_constructor_sound negf Val.negf. -Proof. - red; intros. TrivialExists. -Qed. - -Theorem eval_absf: unary_constructor_sound absf Val.absf. -Proof. - red; intros. TrivialExists. -Qed. - -Theorem eval_addf: binary_constructor_sound addf Val.addf. -Proof. - red; intros; TrivialExists. -Qed. - -Theorem eval_subf: binary_constructor_sound subf Val.subf. -Proof. - red; intros; TrivialExists. -Qed. - -Theorem eval_mulf: binary_constructor_sound mulf Val.mulf. -Proof. - red; intros; TrivialExists. -Qed. - -Theorem eval_negfs: unary_constructor_sound negfs Val.negfs. -Proof. - red; intros. TrivialExists. -Qed. - -Theorem eval_absfs: unary_constructor_sound absfs Val.absfs. -Proof. - red; intros. TrivialExists. -Qed. - -Theorem eval_addfs: binary_constructor_sound addfs Val.addfs. -Proof. - red; intros; TrivialExists. -Qed. - -Theorem eval_subfs: binary_constructor_sound subfs Val.subfs. -Proof. - red; intros; TrivialExists. -Qed. - -Theorem eval_mulfs: binary_constructor_sound mulfs Val.mulfs. -Proof. - red; intros; TrivialExists. -Qed. - -Section COMP_IMM. - -Variable default: comparison -> int -> condition. -Variable intsem: comparison -> int -> int -> bool. -Variable sem: comparison -> val -> val -> val. - -Hypothesis sem_int: forall c x y, sem c (Vint x) (Vint y) = Val.of_bool (intsem c x y). -Hypothesis sem_undef: forall c v, sem c Vundef v = Vundef. -Hypothesis sem_eq: forall x y, sem Ceq (Vint x) (Vint y) = Val.of_bool (Int.eq x y). -Hypothesis sem_ne: forall x y, sem Cne (Vint x) (Vint y) = Val.of_bool (negb (Int.eq x y)). -Hypothesis sem_default: forall c v n, sem c v (Vint n) = Val.of_optbool (eval_condition (default c n) (v :: nil) m). - -Lemma eval_compimm: - forall le c a n2 x, - eval_expr ge sp e m le a x -> - exists v, eval_expr ge sp e m le (compimm default intsem c a n2) v - /\ Val.lessdef (sem c x (Vint n2)) v. -Proof. - intros until x. - unfold compimm; case (compimm_match c a); intros. -(* constant *) - InvEval. rewrite sem_int. TrivialExists. simpl. destruct (intsem c0 n1 n2); auto. -(* eq cmp *) - InvEval. inv H. simpl in H5. inv H5. - destruct (Int.eq_dec n2 Int.zero). subst n2. TrivialExists. - simpl. rewrite eval_negate_condition. - destruct (eval_condition c0 vl m); simpl. - unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_eq; auto. - rewrite sem_undef; auto. - destruct (Int.eq_dec n2 Int.one). subst n2. TrivialExists. - simpl. destruct (eval_condition c0 vl m); simpl. - unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_eq; auto. - rewrite sem_undef; auto. - exists (Vint Int.zero); split. EvalOp. - destruct (eval_condition c0 vl m); simpl. - unfold Vtrue, Vfalse. destruct b; rewrite sem_eq; rewrite Int.eq_false; auto. - rewrite sem_undef; auto. -(* ne cmp *) - InvEval. inv H. simpl in H5. inv H5. - destruct (Int.eq_dec n2 Int.zero). subst n2. TrivialExists. - simpl. destruct (eval_condition c0 vl m); simpl. - unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_ne; auto. - rewrite sem_undef; auto. - destruct (Int.eq_dec n2 Int.one). subst n2. TrivialExists. - simpl. rewrite eval_negate_condition. destruct (eval_condition c0 vl m); simpl. - unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_ne; auto. - rewrite sem_undef; auto. - exists (Vint Int.one); split. EvalOp. - destruct (eval_condition c0 vl m); simpl. - unfold Vtrue, Vfalse. destruct b; rewrite sem_ne; rewrite Int.eq_false; auto. - rewrite sem_undef; auto. -(* eq andimm *) - destruct (Int.eq_dec n2 Int.zero). InvEval; subst. - econstructor; split. EvalOp. simpl; eauto. - destruct v1; simpl; try (rewrite sem_undef; auto). rewrite sem_eq. - destruct (Int.eq (Int.and i n1) Int.zero); auto. - TrivialExists. simpl. rewrite sem_default. auto. -(* ne andimm *) - destruct (Int.eq_dec n2 Int.zero). InvEval; subst. - econstructor; split. EvalOp. simpl; eauto. - destruct v1; simpl; try (rewrite sem_undef; auto). rewrite sem_ne. - destruct (Int.eq (Int.and i n1) Int.zero); auto. - TrivialExists. simpl. rewrite sem_default. auto. -(* default *) - TrivialExists. simpl. rewrite sem_default. auto. -Qed. - -Hypothesis sem_swap: - forall c x y, sem (swap_comparison c) x y = sem c y x. - -Lemma eval_compimm_swap: - forall le c a n2 x, - eval_expr ge sp e m le a x -> - exists v, eval_expr ge sp e m le (compimm default intsem (swap_comparison c) a n2) v - /\ Val.lessdef (sem c (Vint n2) x) v. -Proof. - intros. rewrite <- sem_swap. eapply eval_compimm; eauto. -Qed. - -End COMP_IMM. - -Theorem eval_comp: - forall c, binary_constructor_sound (comp c) (Val.cmp c). -Proof. - intros; red; intros until y. unfold comp; case (comp_match a b); intros; InvEval. - eapply eval_compimm_swap; eauto. - intros. unfold Val.cmp. rewrite Val.swap_cmp_bool; auto. - eapply eval_compimm; eauto. - TrivialExists. -Qed. - -Theorem eval_compu: - forall c, binary_constructor_sound (compu c) (Val.cmpu (Mem.valid_pointer m) c). -Proof. - intros; red; intros until y. unfold compu; case (compu_match a b); intros; InvEval. - eapply eval_compimm_swap; eauto. - intros. unfold Val.cmpu. rewrite Val.swap_cmpu_bool; auto. - eapply eval_compimm; eauto. - TrivialExists. -Qed. - -Theorem eval_compf: - forall c, binary_constructor_sound (compf c) (Val.cmpf c). -Proof. - intros; red; intros. unfold compf. TrivialExists. -Qed. - -Theorem eval_compfs: - forall c, binary_constructor_sound (compfs c) (Val.cmpfs c). -Proof. - intros; red; intros. unfold compfs. TrivialExists. -Qed. - -Theorem eval_cast8signed: unary_constructor_sound cast8signed (Val.sign_ext 8). -Proof. - red; intros until x. unfold cast8signed. case (cast8signed_match a); intros; InvEval. - TrivialExists. - TrivialExists. -Qed. - -Theorem eval_cast8unsigned: unary_constructor_sound cast8unsigned (Val.zero_ext 8). -Proof. - red; intros until x. unfold cast8unsigned. destruct (cast8unsigned_match a); intros; InvEval. - TrivialExists. - subst. rewrite Val.zero_ext_and. rewrite Val.and_assoc. - rewrite Int.and_commut. apply eval_andimm; auto. compute; auto. - TrivialExists. -Qed. - -Theorem eval_cast16signed: unary_constructor_sound cast16signed (Val.sign_ext 16). -Proof. - red; intros until x. unfold cast16signed. case (cast16signed_match a); intros; InvEval. - TrivialExists. - TrivialExists. -Qed. - -Theorem eval_cast16unsigned: unary_constructor_sound cast16unsigned (Val.zero_ext 16). -Proof. - red; intros until x. unfold cast16unsigned. destruct (cast16unsigned_match a); intros; InvEval. - TrivialExists. - subst. rewrite Val.zero_ext_and. rewrite Val.and_assoc. - rewrite Int.and_commut. apply eval_andimm; auto. compute; auto. - TrivialExists. -Qed. - -Theorem eval_singleoffloat: unary_constructor_sound singleoffloat Val.singleoffloat. -Proof. - red; intros. unfold singleoffloat. TrivialExists. -Qed. - -Theorem eval_floatofsingle: unary_constructor_sound floatofsingle Val.floatofsingle. -Proof. - red; intros. unfold floatofsingle. TrivialExists. -Qed. - -Theorem eval_intoffloat: - forall le a x y, - eval_expr ge sp e m le a x -> - Val.intoffloat x = Some y -> - exists v, eval_expr ge sp e m le (intoffloat a) v /\ Val.lessdef y v. -Proof. - intros; unfold intoffloat. TrivialExists. -Qed. - -Theorem eval_floatofint: - forall le a x y, - eval_expr ge sp e m le a x -> - Val.floatofint x = Some y -> - exists v, eval_expr ge sp e m le (floatofint a) v /\ Val.lessdef y v. -Proof. - intros until y; unfold floatofint. case (floatofint_match a); intros; InvEval. - TrivialExists. - TrivialExists. -Qed. - -Theorem eval_intuoffloat: - forall le a x y, - eval_expr ge sp e m le a x -> - Val.intuoffloat x = Some y -> - exists v, eval_expr ge sp e m le (intuoffloat a) v /\ Val.lessdef y v. -Proof. - intros. destruct x; simpl in H0; try discriminate. - destruct (Float.to_intu f) as [n|] eqn:?; simpl in H0; inv H0. - exists (Vint n); split; auto. unfold intuoffloat. - set (im := Int.repr Int.half_modulus). - set (fm := Float.of_intu im). - assert (eval_expr ge sp e m (Vfloat fm :: Vfloat f :: le) (Eletvar (S O)) (Vfloat f)). - constructor. auto. - assert (eval_expr ge sp e m (Vfloat fm :: Vfloat f :: le) (Eletvar O) (Vfloat fm)). - constructor. auto. - econstructor. eauto. - econstructor. instantiate (1 := Vfloat fm). EvalOp. - eapply eval_Econdition with (va := Float.cmp Clt f fm). - eauto with evalexpr. - destruct (Float.cmp Clt f fm) eqn:?. - exploit Float.to_intu_to_int_1; eauto. intro EQ. - EvalOp. simpl. rewrite EQ; auto. - exploit Float.to_intu_to_int_2; eauto. - change Float.ox8000_0000 with im. fold fm. intro EQ. - set (t2 := subf (Eletvar (S O)) (Eletvar O)). - set (t3 := intoffloat t2). - exploit (eval_subf (Vfloat fm :: Vfloat f :: le) (Eletvar (S O)) (Vfloat f) (Eletvar O)); eauto. - fold t2. intros [v2 [A2 B2]]. simpl in B2. inv B2. - exploit (eval_addimm Float.ox8000_0000 (Vfloat fm :: Vfloat f :: le) t3). - unfold t3. unfold intoffloat. EvalOp. simpl. rewrite EQ. simpl. eauto. - intros [v4 [A4 B4]]. simpl in B4. inv B4. - rewrite Int.sub_add_opp in A4. rewrite Int.add_assoc in A4. - rewrite (Int.add_commut (Int.neg im)) in A4. - rewrite Int.add_neg_zero in A4. - rewrite Int.add_zero in A4. - auto. -Qed. - -Theorem eval_floatofintu: - forall le a x y, - eval_expr ge sp e m le a x -> - Val.floatofintu x = Some y -> - exists v, eval_expr ge sp e m le (floatofintu a) v /\ Val.lessdef y v. -Proof. - intros until y; unfold floatofintu. case (floatofintu_match a); intros. - InvEval. TrivialExists. - destruct x; simpl in H0; try discriminate. inv H0. - exists (Vfloat (Float.of_intu i)); split; auto. - econstructor. eauto. - set (fm := Float.of_intu Float.ox8000_0000). - assert (eval_expr ge sp e m (Vint i :: le) (Eletvar O) (Vint i)). - constructor. auto. - eapply eval_Econdition with (va := Int.ltu i Float.ox8000_0000). - eauto with evalexpr. - destruct (Int.ltu i Float.ox8000_0000) eqn:?. - rewrite Float.of_intu_of_int_1; auto. - unfold floatofint. EvalOp. - exploit (eval_addimm (Int.neg Float.ox8000_0000) (Vint i :: le) (Eletvar 0)); eauto. - simpl. intros [v [A B]]. inv B. - unfold addf. EvalOp. - constructor. unfold floatofint. EvalOp. simpl; eauto. - constructor. EvalOp. simpl; eauto. constructor. simpl; eauto. - fold fm. rewrite Float.of_intu_of_int_2; auto. - rewrite Int.sub_add_opp. auto. -Qed. - -Theorem eval_intofsingle: - forall le a x y, - eval_expr ge sp e m le a x -> - Val.intofsingle x = Some y -> - exists v, eval_expr ge sp e m le (intofsingle a) v /\ Val.lessdef y v. -Proof. - intros; unfold intofsingle. TrivialExists. -Qed. - -Theorem eval_singleofint: - forall le a x y, - eval_expr ge sp e m le a x -> - Val.singleofint x = Some y -> - exists v, eval_expr ge sp e m le (singleofint a) v /\ Val.lessdef y v. -Proof. - intros until y; unfold singleofint. case (singleofint_match a); intros; InvEval. - TrivialExists. - TrivialExists. -Qed. - -Theorem eval_intuofsingle: - forall le a x y, - eval_expr ge sp e m le a x -> - Val.intuofsingle x = Some y -> - exists v, eval_expr ge sp e m le (intuofsingle a) v /\ Val.lessdef y v. -Proof. - intros. destruct x; simpl in H0; try discriminate. - destruct (Float32.to_intu f) as [n|] eqn:?; simpl in H0; inv H0. - unfold intuofsingle. apply eval_intuoffloat with (Vfloat (Float.of_single f)). - unfold floatofsingle. EvalOp. - simpl. change (Float.of_single f) with (Float32.to_double f). - erewrite Float32.to_intu_double; eauto. auto. -Qed. - -Theorem eval_singleofintu: - forall le a x y, - eval_expr ge sp e m le a x -> - Val.singleofintu x = Some y -> - exists v, eval_expr ge sp e m le (singleofintu a) v /\ Val.lessdef y v. -Proof. - intros until y; unfold singleofintu. case (singleofintu_match a); intros. - InvEval. TrivialExists. - destruct x; simpl in H0; try discriminate. inv H0. - exploit eval_floatofintu. eauto. simpl. reflexivity. - intros (v & A & B). - exists (Val.singleoffloat v); split. - unfold singleoffloat; EvalOp. - inv B; simpl. rewrite Float32.of_intu_double. auto. -Qed. - -Theorem eval_addressing: - forall le chunk a v b ofs, - eval_expr ge sp e m le a v -> - v = Vptr b ofs -> - match addressing chunk a with (mode, args) => - exists vl, - eval_exprlist ge sp e m le args vl /\ - eval_addressing ge sp mode vl = Some v - end. -Proof. - intros until ofs. - assert (A: v = Vptr b ofs -> eval_addressing ge sp (Aindexed 0) (v :: nil) = Some v). - { intros. subst v. unfold eval_addressing. - destruct Archi.ptr64 eqn:SF; simpl; rewrite SF; rewrite Ptrofs.add_zero; auto. } - assert (D: forall a, - eval_expr ge sp e m le a v -> - v = Vptr b ofs -> - exists vl, eval_exprlist ge sp e m le (a ::: Enil) vl - /\ eval_addressing ge sp (Aindexed 0) vl = Some v). - { intros. exists (v :: nil); split. constructor; auto. constructor. auto. } - unfold addressing; case (addressing_match a); intros. -- destruct (negb Archi.ptr64 && addressing_valid addr) eqn:E. -+ inv H. InvBooleans. apply negb_true_iff in H. unfold eval_addressing; rewrite H. - exists vl; auto. -+ apply D; auto. -- destruct (Archi.ptr64 && addressing_valid addr) eqn:E. -+ inv H. InvBooleans. unfold eval_addressing; rewrite H. - exists vl; auto. -+ apply D; auto. -- apply D; auto. -Qed. - -Theorem eval_builtin_arg: - forall a v, - eval_expr ge sp e m nil a v -> - CminorSel.eval_builtin_arg ge sp e m (builtin_arg a) v. -Proof. - intros until v. unfold builtin_arg; case (builtin_arg_match a); intros; InvEval. -- constructor. -- constructor. -- destruct Archi.ptr64; inv H0. constructor. -- destruct Archi.ptr64; inv H0. constructor. -- destruct Archi.ptr64; inv H0. constructor. -- destruct Archi.ptr64; inv H0. constructor. -- simpl in H5. inv H5. constructor. -- subst v. constructor; auto. -- inv H. InvEval. rewrite eval_addressing_Aglobal in H6. inv H6. constructor; auto. -- inv H. InvEval. rewrite eval_addressing_Ainstack in H6. inv H6. constructor; auto. -- constructor; auto. -Qed. - -End CMCONSTR. diff --git a/ia32/Stacklayout.v b/ia32/Stacklayout.v deleted file mode 100644 index 44fd43b2..00000000 --- a/ia32/Stacklayout.v +++ /dev/null @@ -1,148 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Machine- and ABI-dependent layout information for activation records. *) - -Require Import Coqlib. -Require Import AST Memory Separation. -Require Import Bounds. - -Local Open Scope sep_scope. - -(** The general shape of activation records is as follows, - from bottom (lowest offsets) to top: -- Space for outgoing arguments to function calls. -- Back link to parent frame -- Saved values of integer callee-save registers used by the function. -- Saved values of float callee-save registers used by the function. -- Local stack slots. -- Space for the stack-allocated data declared in Cminor -- Return address. -*) - -Definition fe_ofs_arg := 0. - -Definition make_env (b: bounds) : frame_env := - let w := if Archi.ptr64 then 8 else 4 in - let olink := align (4 * b.(bound_outgoing)) w in (* back link *) - let ocs := olink + w in (* callee-saves *) - let ol := align (size_callee_save_area b ocs) 8 in (* locals *) - let ostkdata := align (ol + 4 * b.(bound_local)) 8 in (* stack data *) - let oretaddr := align (ostkdata + b.(bound_stack_data)) w in (* return address *) - let sz := oretaddr + w in (* total size *) - {| fe_size := sz; - fe_ofs_link := olink; - fe_ofs_retaddr := oretaddr; - fe_ofs_local := ol; - fe_ofs_callee_save := ocs; - fe_stack_data := ostkdata; - fe_used_callee_save := b.(used_callee_save) |}. - -Lemma frame_env_separated: - forall b sp m P, - let fe := make_env b in - m |= range sp 0 (fe_stack_data fe) ** range sp (fe_stack_data fe + bound_stack_data b) (fe_size fe) ** P -> - m |= range sp (fe_ofs_local fe) (fe_ofs_local fe + 4 * bound_local b) - ** range sp fe_ofs_arg (fe_ofs_arg + 4 * bound_outgoing b) - ** range sp (fe_ofs_link fe) (fe_ofs_link fe + size_chunk Mptr) - ** range sp (fe_ofs_retaddr fe) (fe_ofs_retaddr fe + size_chunk Mptr) - ** range sp (fe_ofs_callee_save fe) (size_callee_save_area b (fe_ofs_callee_save fe)) - ** P. -Proof. -Local Opaque Z.add Z.mul sepconj range. - intros; simpl. - set (w := if Archi.ptr64 then 8 else 4). - set (olink := align (4 * b.(bound_outgoing)) w). - set (ocs := olink + w). - set (ol := align (size_callee_save_area b ocs) 8). - set (ostkdata := align (ol + 4 * b.(bound_local)) 8). - set (oretaddr := align (ostkdata + b.(bound_stack_data)) w). - replace (size_chunk Mptr) with w by (rewrite size_chunk_Mptr; auto). - assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). - generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros. - assert (0 <= 4 * b.(bound_outgoing)) by omega. - assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; omega). - assert (olink + w <= ocs) by (unfold ocs; omega). - assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr). - assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega). - assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega). - assert (ostkdata + bound_stack_data b <= oretaddr) by (apply align_le; omega). -(* Reorder as: - outgoing - back link - callee-save - local - retaddr *) - rewrite sep_swap12. - rewrite sep_swap23. - rewrite sep_swap45. - rewrite sep_swap34. -(* Apply range_split and range_split2 repeatedly *) - unfold fe_ofs_arg. - apply range_split_2. fold olink. omega. omega. - apply range_split. omega. - apply range_split_2. fold ol. omega. omega. - apply range_drop_right with ostkdata. omega. - rewrite sep_swap. - apply range_drop_left with (ostkdata + bound_stack_data b). omega. - rewrite sep_swap. - exact H. -Qed. - -Lemma frame_env_range: - forall b, - let fe := make_env b in - 0 <= fe_stack_data fe /\ fe_stack_data fe + bound_stack_data b <= fe_size fe. -Proof. - intros; simpl. - set (w := if Archi.ptr64 then 8 else 4). - set (olink := align (4 * b.(bound_outgoing)) w). - set (ocs := olink + w). - set (ol := align (size_callee_save_area b ocs) 8). - set (ostkdata := align (ol + 4 * b.(bound_local)) 8). - set (oretaddr := align (ostkdata + b.(bound_stack_data)) w). - assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). - generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros. - assert (0 <= 4 * b.(bound_outgoing)) by omega. - assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; omega). - assert (olink + w <= ocs) by (unfold ocs; omega). - assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr). - assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega). - assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega). - assert (ostkdata + bound_stack_data b <= oretaddr) by (apply align_le; omega). - split. omega. omega. -Qed. - -Lemma frame_env_aligned: - forall b, - let fe := make_env b in - (8 | fe_ofs_arg) - /\ (8 | fe_ofs_local fe) - /\ (8 | fe_stack_data fe) - /\ (align_chunk Mptr | fe_ofs_link fe) - /\ (align_chunk Mptr | fe_ofs_retaddr fe). -Proof. - intros; simpl. - set (w := if Archi.ptr64 then 8 else 4). - set (olink := align (4 * b.(bound_outgoing)) w). - set (ocs := olink + w). - set (ol := align (size_callee_save_area b ocs) 8). - set (ostkdata := align (ol + 4 * b.(bound_local)) 8). - set (oretaddr := align (ostkdata + b.(bound_stack_data)) w). - assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). - replace (align_chunk Mptr) with w by (rewrite align_chunk_Mptr; auto). - split. apply Zdivide_0. - split. apply align_divides; omega. - split. apply align_divides; omega. - split. apply align_divides; omega. - apply align_divides; omega. -Qed. diff --git a/ia32/TargetPrinter.ml b/ia32/TargetPrinter.ml deleted file mode 100644 index 33d47830..00000000 --- a/ia32/TargetPrinter.ml +++ /dev/null @@ -1,881 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(* Printing x86-64 assembly code in asm syntax *) - -open Printf -open !Datatypes -open Camlcoq -open Sections -open AST -open Asm -open PrintAsmaux -open Fileinfo - -module StringSet = Set.Make(String) - -(* Basic printing functions used in definition of the systems *) - -let int64_reg_name = function - | RAX -> "%rax" | RBX -> "%rbx" | RCX -> "%rcx" | RDX -> "%rdx" - | RSI -> "%rsi" | RDI -> "%rdi" | RBP -> "%rbp" | RSP -> "%rsp" - | R8 -> "%r8" | R9 -> "%r9" | R10 -> "%r10" | R11 -> "%r11" - | R12 -> "%r12" | R13 -> "%r13" | R14 -> "%r14" | R15 -> "%r15" - -let int32_reg_name = function - | RAX -> "%eax" | RBX -> "%ebx" | RCX -> "%ecx" | RDX -> "%edx" - | RSI -> "%esi" | RDI -> "%edi" | RBP -> "%ebp" | RSP -> "%esp" - | R8 -> "%r8d" | R9 -> "%r9d" | R10 -> "%r10d" | R11 -> "%r11d" - | R12 -> "%r12d" | R13 -> "%r13d" | R14 -> "%r14d" | R15 -> "%r15d" - -let int8_reg_name = function - | RAX -> "%al" | RBX -> "%bl" | RCX -> "%cl" | RDX -> "%dl" - | RSI -> "%sil" | RDI -> "%dil" | RBP -> "%bpl" | RSP -> "%spl" - | R8 -> "%r8b" | R9 -> "%r9b" | R10 -> "%r10b" | R11 -> "%r11b" - | R12 -> "%r12b" | R13 -> "%r13b" | R14 -> "%r14b" | R15 -> "%r15b" - -let int16_reg_name = function - | RAX -> "%ax" | RBX -> "%bx" | RCX -> "%cx" | RDX -> "%dx" - | RSI -> "%si" | RDI -> "%di" | RBP -> "%bp" | RSP -> "%sp" - | R8 -> "%r8w" | R9 -> "%r9w" | R10 -> "%r10w" | R11 -> "%r11w" - | R12 -> "%r12w" | R13 -> "%r13w" | R14 -> "%r14w" | R15 -> "%r15w" - -let float_reg_name = function - | XMM0 -> "%xmm0" | XMM1 -> "%xmm1" | XMM2 -> "%xmm2" | XMM3 -> "%xmm3" - | XMM4 -> "%xmm4" | XMM5 -> "%xmm5" | XMM6 -> "%xmm6" | XMM7 -> "%xmm7" - | XMM8 -> "%xmm8" | XMM9 -> "%xmm9" | XMM10 -> "%xmm10" | XMM11 -> "%xmm11" - | XMM12 -> "%xmm12" | XMM13 -> "%xmm13" | XMM14 -> "%xmm14" | XMM15 -> "%xmm15" - -let ireg8 oc r = output_string oc (int8_reg_name r) -let ireg16 oc r = output_string oc (int16_reg_name r) -let ireg32 oc r = output_string oc (int32_reg_name r) -let ireg64 oc r = output_string oc (int64_reg_name r) -let ireg = if Archi.ptr64 then ireg64 else ireg32 -let freg oc r = output_string oc (float_reg_name r) - -let preg oc = function - | IR r -> ireg oc r - | FR r -> freg oc r - | _ -> assert false - -let z oc n = output_string oc (Z.to_string n) - -(* 32/64 bit dependencies *) - -let data_pointer = if Archi.ptr64 then ".quad" else ".long" - -(* The comment deliminiter *) -let comment = "#" - -(* System dependend printer functions *) -module type SYSTEM = - sig - val raw_symbol: out_channel -> string -> unit - val symbol: out_channel -> P.t -> unit - val label: out_channel -> int -> unit - val name_of_section: section_name -> string - val stack_alignment: int - val print_align: out_channel -> int -> unit - val print_mov_rs: out_channel -> ireg -> ident -> unit - val print_fun_info: out_channel -> P.t -> unit - val print_var_info: out_channel -> P.t -> unit - val print_epilogue: out_channel -> unit - val print_comm_decl: out_channel -> P.t -> Z.t -> int -> unit - val print_lcomm_decl: out_channel -> P.t -> Z.t -> int -> unit - end - -(* Printer functions for ELF *) -module ELF_System : SYSTEM = - struct - - let raw_symbol oc s = - fprintf oc "%s" s - - let symbol = elf_symbol - - let label = elf_label - - let name_of_section = function - | Section_text -> ".text" - | Section_data i | Section_small_data i -> - if i then ".data" else "COMM" - | Section_const i | Section_small_const i -> - if i then ".section .rodata" else "COMM" - | Section_string -> ".section .rodata" - | Section_literal -> ".section .rodata.cst8,\"aM\",@progbits,8" - | Section_jumptable -> ".text" - | Section_user(s, wr, ex) -> - sprintf ".section \"%s\",\"a%s%s\",@progbits" - s (if wr then "w" else "") (if ex then "x" else "") - | Section_debug_info _ -> ".section .debug_info,\"\",@progbits" - | Section_debug_loc -> ".section .debug_loc,\"\",@progbits" - | Section_debug_line _ -> ".section .debug_line,\"\",@progbits" - | Section_debug_abbrev -> ".section .debug_abbrev,\"\",@progbits" - | Section_debug_ranges -> ".section .debug_ranges,\"\",@progbits" - | Section_debug_str -> ".section .debug_str,\"MS\",@progbits,1" - - let stack_alignment = 16 - - let print_align oc n = - fprintf oc " .align %d\n" n - - let print_mov_rs oc rd id = - if Archi.ptr64 - then fprintf oc " movq %a@GOTPCREL(%%rip), %a\n" symbol id ireg64 rd - else fprintf oc " movl $%a, %a\n" symbol id ireg32 rd - - let print_fun_info = elf_print_fun_info - - let print_var_info = elf_print_var_info - - let print_epilogue _ = () - - let print_comm_decl oc name sz al = - fprintf oc " .comm %a, %s, %d\n" symbol name (Z.to_string sz) al - - let print_lcomm_decl oc name sz al = - fprintf oc " .local %a\n" symbol name; - print_comm_decl oc name sz al - - end - -(* Printer functions for MacOS *) -module MacOS_System : SYSTEM = - struct - - let raw_symbol oc s = - fprintf oc "_%s" s - - let symbol oc symb = - raw_symbol oc (extern_atom symb) - - let label oc lbl = - fprintf oc "L%d" lbl - - let name_of_section = function - | Section_text -> ".text" - | Section_data i | Section_small_data i -> - if i then ".data" else "COMM" - | Section_const i | Section_small_const i -> - if i then ".const" else "COMM" - | Section_string -> ".const" - | Section_literal -> ".literal8" - | Section_jumptable -> ".const" - | Section_user(s, wr, ex) -> - sprintf ".section \"%s\", %s, %s" - (if wr then "__DATA" else "__TEXT") s - (if ex then "regular, pure_instructions" else "regular") - | Section_debug_info _ -> ".section __DWARF,__debug_info,regular,debug" - | Section_debug_loc -> ".section __DWARF,__debug_loc,regular,debug" - | Section_debug_line _ -> ".section __DWARF,__debug_line,regular,debug" - | Section_debug_str -> ".section __DWARF,__debug_str,regular,debug" - | Section_debug_ranges -> ".section __DWARF,__debug_ranges,regular,debug" - | Section_debug_abbrev -> ".section __DWARF,__debug_abbrev,regular,debug" - - - let stack_alignment = 16 (* mandatory *) - - (* Base-2 log of a Caml integer *) - let rec log2 n = - assert (n > 0); - if n = 1 then 0 else 1 + log2 (n lsr 1) - - let print_align oc n = - fprintf oc " .align %d\n" (log2 n) - - let indirect_symbols : StringSet.t ref = ref StringSet.empty - - let print_mov_rs oc rd id = - if Archi.ptr64 then begin - fprintf oc " movq %a@GOTPCREL(%%rip), %a\n" symbol id ireg64 rd - end else begin - let id = extern_atom id in - indirect_symbols := StringSet.add id !indirect_symbols; - fprintf oc " movl L%a$non_lazy_ptr, %a\n" raw_symbol id ireg rd - end - - let print_fun_info _ _ = () - - let print_var_info _ _ = () - - let print_epilogue oc = - if not Archi.ptr64 then begin - fprintf oc " .section __IMPORT,__pointers,non_lazy_symbol_pointers\n"; - StringSet.iter - (fun s -> - fprintf oc "L%a$non_lazy_ptr:\n" raw_symbol s; - fprintf oc " .indirect_symbol %a\n" raw_symbol s; - fprintf oc " .long 0\n") - !indirect_symbols; - indirect_symbols := StringSet.empty - end - - let print_comm_decl oc name sz al = - fprintf oc " .comm %a, %s, %d\n" - symbol name (Z.to_string sz) (log2 al) - - let print_lcomm_decl oc name sz al = - fprintf oc " .lcomm %a, %s, %d\n" - symbol name (Z.to_string sz) (log2 al) - - end - - -module Target(System: SYSTEM):TARGET = - struct - open System - let symbol = symbol - -(* Basic printing functions *) - - let symbol_offset oc (symb, ofs) = - symbol oc symb; - let ofs = Z.to_int64 ofs in - if ofs <> 0L then fprintf oc " + %Ld" ofs - - let addressing_gen ireg oc (Addrmode(base, shift, cst)) = - begin match cst with - | Coq_inl n -> - fprintf oc "%s" (Z.to_string n) - | Coq_inr(id, ofs) -> - if Archi.ptr64 then begin - (* RIP-relative addressing *) - let ofs' = Z.to_int64 ofs in - if ofs' = 0L - then fprintf oc "%a(%%rip)" symbol id - else fprintf oc "(%a + %Ld)(%%rip)" symbol id ofs' - end else begin - (* Absolute addressing *) - let ofs' = Z.to_int32 ofs in - if ofs' = 0l - then fprintf oc "%a" symbol id - else fprintf oc "(%a + %ld)" symbol id ofs' - end - end; - begin match base, shift with - | None, None -> () - | Some r1, None -> fprintf oc "(%a)" ireg r1 - | None, Some(r2,sc) -> fprintf oc "(,%a,%a)" ireg r2 z sc - | Some r1, Some(r2,sc) -> fprintf oc "(%a,%a,%a)" ireg r1 ireg r2 z sc - end - - let addressing32 = addressing_gen ireg32 - let addressing64 = addressing_gen ireg64 - let addressing = addressing_gen ireg - - let name_of_condition = function - | Cond_e -> "e" | Cond_ne -> "ne" - | Cond_b -> "b" | Cond_be -> "be" | Cond_ae -> "ae" | Cond_a -> "a" - | Cond_l -> "l" | Cond_le -> "le" | Cond_ge -> "ge" | Cond_g -> "g" - | Cond_p -> "p" | Cond_np -> "np" - - let name_of_neg_condition = function - | Cond_e -> "ne" | Cond_ne -> "e" - | Cond_b -> "ae" | Cond_be -> "a" | Cond_ae -> "b" | Cond_a -> "be" - | Cond_l -> "ge" | Cond_le -> "g" | Cond_ge -> "l" | Cond_g -> "le" - | Cond_p -> "np" | Cond_np -> "p" - - -(* Names of sections *) - - let section oc sec = - fprintf oc " %s\n" (name_of_section sec) - -(* For "abs" and "neg" FP operations *) - - let need_masks = ref false - -(* Emit .file / .loc debugging directives *) - - let print_file_line oc file line = - print_file_line oc comment file line - -(* In 64-bit mode use RIP-relative addressing to designate labels *) - - let rip_rel = - if Archi.ptr64 then "(%rip)" else "" - -(* Large 64-bit immediates (bigger than a 32-bit signed integer) are - not supported by the processor. Turn them into memory operands. *) - - let intconst64 oc n = - let n1 = camlint64_of_coqint n in - let n2 = Int64.to_int32 n1 in - if n1 = Int64.of_int32 n2 then - (* fit in a 32-bit signed integer, can use as immediate *) - fprintf oc "$%ld" n2 - else begin - (* put the constant in memory and use a PC-relative memory operand *) - let lbl = new_label() in - float64_literals := (lbl, n1) :: !float64_literals; - fprintf oc "%a(%%rip)" label lbl - end - - - -(* Printing of instructions *) - -(* Reminder on AT&T syntax: op source, dest *) - - let print_instruction oc = function - (* Moves *) - | Pmov_rr(rd, r1) -> - if Archi.ptr64 - then fprintf oc " movq %a, %a\n" ireg64 r1 ireg64 rd - else fprintf oc " movl %a, %a\n" ireg32 r1 ireg32 rd - | Pmovl_ri(rd, n) -> - fprintf oc " movl $%ld, %a\n" (camlint_of_coqint n) ireg32 rd - | Pmovq_ri(rd, n) -> - let n1 = camlint64_of_coqint n in - let n2 = Int64.to_int32 n1 in - if n1 = Int64.of_int32 n2 then - fprintf oc " movq $%ld, %a\n" n2 ireg64 rd - else - fprintf oc " movabsq $%Ld, %a\n" n1 ireg64 rd - | Pmov_rs(rd, id) -> - print_mov_rs oc rd id - | Pmovl_rm(rd, a) -> - fprintf oc " movl %a, %a\n" addressing a ireg32 rd - | Pmovq_rm(rd, a) -> - fprintf oc " movq %a, %a\n" addressing a ireg64 rd - | Pmov_rm_a(rd, a) -> - if Archi.ptr64 - then fprintf oc " movq %a, %a\n" addressing a ireg64 rd - else fprintf oc " movl %a, %a\n" addressing a ireg32 rd - | Pmovl_mr(a, r1) -> - fprintf oc " movl %a, %a\n" ireg32 r1 addressing a - | Pmovq_mr(a, r1) -> - fprintf oc " movq %a, %a\n" ireg64 r1 addressing a - | Pmov_mr_a(a, r1) -> - if Archi.ptr64 - then fprintf oc " movq %a, %a\n" ireg64 r1 addressing a - else fprintf oc " movl %a, %a\n" ireg32 r1 addressing a - | Pmovsd_ff(rd, r1) -> - fprintf oc " movapd %a, %a\n" freg r1 freg rd - | Pmovsd_fi(rd, n) -> - let b = camlint64_of_coqint (Floats.Float.to_bits n) in - let lbl = new_label() in - fprintf oc " movsd %a%s, %a %s %.18g\n" - label lbl rip_rel - freg rd comment (camlfloat_of_coqfloat n); - float64_literals := (lbl, b) :: !float64_literals - | Pmovsd_fm(rd, a) | Pmovsd_fm_a(rd, a) -> - fprintf oc " movsd %a, %a\n" addressing a freg rd - | Pmovsd_mf(a, r1) | Pmovsd_mf_a(a, r1) -> - fprintf oc " movsd %a, %a\n" freg r1 addressing a - | Pmovss_fi(rd, n) -> - let b = camlint_of_coqint (Floats.Float32.to_bits n) in - let lbl = new_label() in - fprintf oc " movss %a%s, %a %s %.18g\n" - label lbl rip_rel - freg rd comment (camlfloat_of_coqfloat32 n); - float32_literals := (lbl, b) :: !float32_literals - | Pmovss_fm(rd, a) -> - fprintf oc " movss %a, %a\n" addressing a freg rd - | Pmovss_mf(a, r1) -> - fprintf oc " movss %a, %a\n" freg r1 addressing a - | Pfldl_m(a) -> - fprintf oc " fldl %a\n" addressing a - | Pfstpl_m(a) -> - fprintf oc " fstpl %a\n" addressing a - | Pflds_m(a) -> - fprintf oc " flds %a\n" addressing a - | Pfstps_m(a) -> - fprintf oc " fstps %a\n" addressing a - (* Moves with conversion *) - | Pmovb_mr(a, r1) -> - fprintf oc " movb %a, %a\n" ireg8 r1 addressing a - | Pmovw_mr(a, r1) -> - fprintf oc " movw %a, %a\n" ireg16 r1 addressing a - | Pmovzb_rr(rd, r1) -> - fprintf oc " movzbl %a, %a\n" ireg8 r1 ireg32 rd - | Pmovzb_rm(rd, a) -> - fprintf oc " movzbl %a, %a\n" addressing a ireg32 rd - | Pmovsb_rr(rd, r1) -> - fprintf oc " movsbl %a, %a\n" ireg8 r1 ireg32 rd - | Pmovsb_rm(rd, a) -> - fprintf oc " movsbl %a, %a\n" addressing a ireg32 rd - | Pmovzw_rr(rd, r1) -> - fprintf oc " movzwl %a, %a\n" ireg16 r1 ireg32 rd - | Pmovzw_rm(rd, a) -> - fprintf oc " movzwl %a, %a\n" addressing a ireg32 rd - | Pmovsw_rr(rd, r1) -> - fprintf oc " movswl %a, %a\n" ireg16 r1 ireg32 rd - | Pmovsw_rm(rd, a) -> - fprintf oc " movswl %a, %a\n" addressing a ireg32 rd - | Pmovzl_rr(rd, r1) -> - fprintf oc " movl %a, %a\n" ireg32 r1 ireg32 rd - (* movl sets the high 32 bits of the destination to zero *) - | Pmovsl_rr(rd, r1) -> - fprintf oc " movslq %a, %a\n" ireg32 r1 ireg64 rd - | Pmovls_rr(rd) -> - () (* nothing to do *) - | Pcvtsd2ss_ff(rd, r1) -> - fprintf oc " cvtsd2ss %a, %a\n" freg r1 freg rd - | Pcvtss2sd_ff(rd, r1) -> - fprintf oc " cvtss2sd %a, %a\n" freg r1 freg rd - | Pcvttsd2si_rf(rd, r1) -> - fprintf oc " cvttsd2si %a, %a\n" freg r1 ireg32 rd - | Pcvtsi2sd_fr(rd, r1) -> - fprintf oc " cvtsi2sd %a, %a\n" ireg32 r1 freg rd - | Pcvttss2si_rf(rd, r1) -> - fprintf oc " cvttss2si %a, %a\n" freg r1 ireg32 rd - | Pcvtsi2ss_fr(rd, r1) -> - fprintf oc " cvtsi2ss %a, %a\n" ireg32 r1 freg rd - | Pcvttsd2sl_rf(rd, r1) -> - fprintf oc " cvttsd2si %a, %a\n" freg r1 ireg64 rd - | Pcvtsl2sd_fr(rd, r1) -> - fprintf oc " cvtsi2sdq %a, %a\n" ireg64 r1 freg rd - | Pcvttss2sl_rf(rd, r1) -> - fprintf oc " cvttss2si %a, %a\n" freg r1 ireg64 rd - | Pcvtsl2ss_fr(rd, r1) -> - fprintf oc " cvtsi2ssq %a, %a\n" ireg64 r1 freg rd - (* Arithmetic and logical operations over integers *) - | Pleal(rd, a) -> - fprintf oc " leal %a, %a\n" addressing32 a ireg32 rd - | Pleaq(rd, a) -> - fprintf oc " leaq %a, %a\n" addressing64 a ireg64 rd - | Pnegl(rd) -> - fprintf oc " negl %a\n" ireg32 rd - | Pnegq(rd) -> - fprintf oc " negq %a\n" ireg64 rd - | Paddl_ri (res,n) -> - fprintf oc " addl $%ld, %a\n" (camlint_of_coqint n) ireg32 res - | Paddq_ri (res,n) -> - fprintf oc " addq %a, %a\n" intconst64 n ireg64 res - | Psubl_rr(rd, r1) -> - fprintf oc " subl %a, %a\n" ireg32 r1 ireg32 rd - | Psubq_rr(rd, r1) -> - fprintf oc " subq %a, %a\n" ireg64 r1 ireg64 rd - | Pimull_rr(rd, r1) -> - fprintf oc " imull %a, %a\n" ireg32 r1 ireg32 rd - | Pimulq_rr(rd, r1) -> - fprintf oc " imulq %a, %a\n" ireg64 r1 ireg64 rd - | Pimull_ri(rd, n) -> - fprintf oc " imull $%a, %a\n" coqint n ireg32 rd - | Pimulq_ri(rd, n) -> - fprintf oc " imulq %a, %a\n" intconst64 n ireg64 rd - | Pimull_r(r1) -> - fprintf oc " imull %a\n" ireg32 r1 - | Pimulq_r(r1) -> - fprintf oc " imulq %a\n" ireg64 r1 - | Pmull_r(r1) -> - fprintf oc " mull %a\n" ireg32 r1 - | Pmulq_r(r1) -> - fprintf oc " mulq %a\n" ireg64 r1 - | Pcltd -> - fprintf oc " cltd\n" - | Pcqto -> - fprintf oc " cqto\n"; - | Pdivl(r1) -> - fprintf oc " divl %a\n" ireg32 r1 - | Pdivq(r1) -> - fprintf oc " divq %a\n" ireg64 r1 - | Pidivl(r1) -> - fprintf oc " idivl %a\n" ireg32 r1 - | Pidivq(r1) -> - fprintf oc " idivq %a\n" ireg64 r1 - | Pandl_rr(rd, r1) -> - fprintf oc " andl %a, %a\n" ireg32 r1 ireg32 rd - | Pandq_rr(rd, r1) -> - fprintf oc " andq %a, %a\n" ireg64 r1 ireg64 rd - | Pandl_ri(rd, n) -> - fprintf oc " andl $%a, %a\n" coqint n ireg32 rd - | Pandq_ri(rd, n) -> - fprintf oc " andq %a, %a\n" intconst64 n ireg64 rd - | Porl_rr(rd, r1) -> - fprintf oc " orl %a, %a\n" ireg32 r1 ireg32 rd - | Porq_rr(rd, r1) -> - fprintf oc " orq %a, %a\n" ireg64 r1 ireg64 rd - | Porl_ri(rd, n) -> - fprintf oc " orl $%a, %a\n" coqint n ireg32 rd - | Porq_ri(rd, n) -> - fprintf oc " orq %a, %a\n" intconst64 n ireg64 rd - | Pxorl_r(rd) -> - fprintf oc " xorl %a, %a\n" ireg32 rd ireg32 rd - | Pxorq_r(rd) -> - fprintf oc " xorq %a, %a\n" ireg64 rd ireg64 rd - | Pxorl_rr(rd, r1) -> - fprintf oc " xorl %a, %a\n" ireg32 r1 ireg32 rd - | Pxorq_rr(rd, r1) -> - fprintf oc " xorq %a, %a\n" ireg64 r1 ireg64 rd - | Pxorl_ri(rd, n) -> - fprintf oc " xorl $%a, %a\n" coqint n ireg32 rd - | Pxorq_ri(rd, n) -> - fprintf oc " xorq %a, %a\n" intconst64 n ireg64 rd - | Pnotl(rd) -> - fprintf oc " notl %a\n" ireg32 rd - | Pnotq(rd) -> - fprintf oc " notq %a\n" ireg64 rd - | Psall_rcl(rd) -> - fprintf oc " sall %%cl, %a\n" ireg32 rd - | Psalq_rcl(rd) -> - fprintf oc " salq %%cl, %a\n" ireg64 rd - | Psall_ri(rd, n) -> - fprintf oc " sall $%a, %a\n" coqint n ireg32 rd - | Psalq_ri(rd, n) -> - fprintf oc " salq $%a, %a\n" coqint n ireg64 rd - | Pshrl_rcl(rd) -> - fprintf oc " shrl %%cl, %a\n" ireg32 rd - | Pshrq_rcl(rd) -> - fprintf oc " shrq %%cl, %a\n" ireg64 rd - | Pshrl_ri(rd, n) -> - fprintf oc " shrl $%a, %a\n" coqint n ireg32 rd - | Pshrq_ri(rd, n) -> - fprintf oc " shrq $%a, %a\n" coqint n ireg64 rd - | Psarl_rcl(rd) -> - fprintf oc " sarl %%cl, %a\n" ireg32 rd - | Psarq_rcl(rd) -> - fprintf oc " sarq %%cl, %a\n" ireg64 rd - | Psarl_ri(rd, n) -> - fprintf oc " sarl $%a, %a\n" coqint n ireg32 rd - | Psarq_ri(rd, n) -> - fprintf oc " sarq $%a, %a\n" coqint n ireg64 rd - | Pshld_ri(rd, r1, n) -> - fprintf oc " shldl $%a, %a, %a\n" coqint n ireg32 r1 ireg32 rd - | Prorl_ri(rd, n) -> - fprintf oc " rorl $%a, %a\n" coqint n ireg32 rd - | Prorq_ri(rd, n) -> - fprintf oc " rorq $%a, %a\n" coqint n ireg64 rd - | Pcmpl_rr(r1, r2) -> - fprintf oc " cmpl %a, %a\n" ireg32 r2 ireg32 r1 - | Pcmpq_rr(r1, r2) -> - fprintf oc " cmpq %a, %a\n" ireg64 r2 ireg64 r1 - | Pcmpl_ri(r1, n) -> - fprintf oc " cmpl $%a, %a\n" coqint n ireg32 r1 - | Pcmpq_ri(r1, n) -> - fprintf oc " cmpq %a, %a\n" intconst64 n ireg64 r1 - | Ptestl_rr(r1, r2) -> - fprintf oc " testl %a, %a\n" ireg32 r2 ireg32 r1 - | Ptestq_rr(r1, r2) -> - fprintf oc " testq %a, %a\n" ireg64 r2 ireg64 r1 - | Ptestl_ri(r1, n) -> - fprintf oc " testl $%a, %a\n" coqint n ireg32 r1 - | Ptestq_ri(r1, n) -> - fprintf oc " testl %a, %a\n" intconst64 n ireg64 r1 - | Pcmov(c, rd, r1) -> - fprintf oc " cmov%s %a, %a\n" (name_of_condition c) ireg r1 ireg rd - | Psetcc(c, rd) -> - fprintf oc " set%s %a\n" (name_of_condition c) ireg8 rd; - fprintf oc " movzbl %a, %a\n" ireg8 rd ireg32 rd - (* Arithmetic operations over floats *) - | Paddd_ff(rd, r1) -> - fprintf oc " addsd %a, %a\n" freg r1 freg rd - | Psubd_ff(rd, r1) -> - fprintf oc " subsd %a, %a\n" freg r1 freg rd - | Pmuld_ff(rd, r1) -> - fprintf oc " mulsd %a, %a\n" freg r1 freg rd - | Pdivd_ff(rd, r1) -> - fprintf oc " divsd %a, %a\n" freg r1 freg rd - | Pnegd (rd) -> - need_masks := true; - fprintf oc " xorpd %a%s, %a\n" - raw_symbol "__negd_mask" rip_rel freg rd - | Pabsd (rd) -> - need_masks := true; - fprintf oc " andpd %a%s, %a\n" - raw_symbol "__absd_mask" rip_rel freg rd - | Pcomisd_ff(r1, r2) -> - fprintf oc " comisd %a, %a\n" freg r2 freg r1 - | Pxorpd_f (rd) -> - fprintf oc " xorpd %a, %a\n" freg rd freg rd - | Padds_ff(rd, r1) -> - fprintf oc " addss %a, %a\n" freg r1 freg rd - | Psubs_ff(rd, r1) -> - fprintf oc " subss %a, %a\n" freg r1 freg rd - | Pmuls_ff(rd, r1) -> - fprintf oc " mulss %a, %a\n" freg r1 freg rd - | Pdivs_ff(rd, r1) -> - fprintf oc " divss %a, %a\n" freg r1 freg rd - | Pnegs (rd) -> - need_masks := true; - fprintf oc " xorpd %a%s, %a\n" - raw_symbol "__negs_mask" rip_rel freg rd - | Pabss (rd) -> - need_masks := true; - fprintf oc " andpd %a%s, %a\n" - raw_symbol "__abss_mask" rip_rel freg rd - | Pcomiss_ff(r1, r2) -> - fprintf oc " comiss %a, %a\n" freg r2 freg r1 - | Pxorps_f (rd) -> - fprintf oc " xorpd %a, %a\n" freg rd freg rd - (* Branches and calls *) - | Pjmp_l(l) -> - fprintf oc " jmp %a\n" label (transl_label l) - | Pjmp_s(f, sg) -> - fprintf oc " jmp %a\n" symbol f - | Pjmp_r(r, sg) -> - fprintf oc " jmp *%a\n" ireg r - | Pjcc(c, l) -> - let l = transl_label l in - fprintf oc " j%s %a\n" (name_of_condition c) label l - | Pjcc2(c1, c2, l) -> - let l = transl_label l in - let l' = new_label() in - fprintf oc " j%s %a\n" (name_of_neg_condition c1) label l'; - fprintf oc " j%s %a\n" (name_of_condition c2) label l; - fprintf oc "%a:\n" label l' - | Pjmptbl(r, tbl) -> - let l = new_label() in - jumptables := (l, tbl) :: !jumptables; - if Archi.ptr64 then begin - let (tmp1, tmp2) = - if r = RAX then (RDX, RAX) else (RAX, RDX) in - fprintf oc " leaq %a(%%rip), %a\n" label l ireg tmp1; - fprintf oc " movslq (%a, %a, 4), %a\n" ireg tmp1 ireg r ireg tmp2; - fprintf oc " addq %a, %a\n" ireg tmp2 ireg tmp1; - fprintf oc " jmp *%a\n" ireg tmp1 - end else begin - fprintf oc " jmp *%a(, %a, 4)\n" label l ireg r - end - | Pcall_s(f, sg) -> - fprintf oc " call %a\n" symbol f; - if (not Archi.ptr64) && sg.sig_cc.cc_structret then - fprintf oc " pushl %%eax\n" - | Pcall_r(r, sg) -> - fprintf oc " call *%a\n" ireg r; - if (not Archi.ptr64) && sg.sig_cc.cc_structret then - fprintf oc " pushl %%eax\n" - | Pret -> - if (not Archi.ptr64) - && (!current_function_sig).sig_cc.cc_structret then begin - fprintf oc " movl 0(%%esp), %%eax\n"; - fprintf oc " ret $4\n" - end else begin - fprintf oc " ret\n" - end - (* Instructions produced by Asmexpand *) - | Padcl_ri (res,n) -> - fprintf oc " adcl $%ld, %a\n" (camlint_of_coqint n) ireg32 res; - | Padcl_rr (res,a1) -> - fprintf oc " adcl %a, %a\n" ireg32 a1 ireg32 res; - | Paddl_rr (res,a1) -> - fprintf oc " addl %a, %a\n" ireg32 a1 ireg32 res; - | Paddl_mi (addr,n) -> - fprintf oc " addl $%ld, %a\n" (camlint_of_coqint n) addressing addr - | Pbsfl (res,a1) -> - fprintf oc " bsfl %a, %a\n" ireg32 a1 ireg32 res - | Pbsfq (res,a1) -> - fprintf oc " bsfq %a, %a\n" ireg64 a1 ireg64 res - | Pbsrl (res,a1) -> - fprintf oc " bsrl %a, %a\n" ireg32 a1 ireg32 res - | Pbsrq (res,a1) -> - fprintf oc " bsrq %a, %a\n" ireg64 a1 ireg64 res - | Pbswap64 res -> - fprintf oc " bswap %a\n" ireg64 res - | Pbswap32 res -> - fprintf oc " bswap %a\n" ireg32 res - | Pbswap16 res -> - fprintf oc " rolw $8, %a\n" ireg16 res - | Pcfi_adjust sz -> - cfi_adjust oc (camlint_of_coqint sz) - | Pfmadd132 (res,a1,a2) -> - fprintf oc " vfmadd132sd %a, %a, %a\n" freg a1 freg a2 freg res - | Pfmadd213 (res,a1,a2) -> - fprintf oc " vfmadd213sd %a, %a, %a\n" freg a1 freg a2 freg res - | Pfmadd231 (res,a1,a2) -> - fprintf oc " vfmadd231sd %a, %a, %a\n" freg a1 freg a2 freg res - | Pfmsub132 (res,a1,a2) -> - fprintf oc " vfmsub132sd %a, %a, %a\n" freg a1 freg a2 freg res - | Pfmsub213 (res,a1,a2) -> - fprintf oc " vfmsub213sd %a, %a, %a\n" freg a1 freg a2 freg res - | Pfmsub231 (res,a1,a2) -> - fprintf oc " vfmsub231sd %a, %a, %a\n" freg a1 freg a2 freg res - | Pfnmadd132 (res,a1,a2) -> - fprintf oc " vfnmadd132sd %a, %a, %a\n" freg a1 freg a2 freg res - | Pfnmadd213 (res,a1,a2) -> - fprintf oc " vfnmadd213sd %a, %a, %a\n" freg a1 freg a2 freg res - | Pfnmadd231 (res,a1,a2) -> - fprintf oc " vfnmadd231sd %a, %a, %a\n" freg a1 freg a2 freg res - | Pfnmsub132 (res,a1,a2) -> - fprintf oc " vfnmsub132sd %a, %a, %a\n" freg a1 freg a2 freg res - | Pfnmsub213 (res,a1,a2) -> - fprintf oc " vfnmsub213sd %a, %a, %a\n" freg a1 freg a2 freg res - | Pfnmsub231 (res,a1,a2) -> - fprintf oc " vfnmsub231sd %a, %a, %a\n" freg a1 freg a2 freg res - | Pmaxsd (res,a1) -> - fprintf oc " maxsd %a, %a\n" freg a1 freg res - | Pminsd (res,a1) -> - fprintf oc " minsd %a, %a\n" freg a1 freg res - | Pmovb_rm (rd,a) -> - fprintf oc " movb %a, %a\n" addressing a ireg8 rd - | Pmovsq_mr(a, rs) -> - fprintf oc " movq %a, %a\n" freg rs addressing a - | Pmovsq_rm(rd, a) -> - fprintf oc " movq %a, %a\n" addressing a freg rd - | Pmovsb -> - fprintf oc " movsb\n"; - | Pmovsw -> - fprintf oc " movsw\n"; - | Pmovw_rm (rd, a) -> - fprintf oc " movw %a, %a\n" addressing a ireg16 rd - | Prep_movsl -> - fprintf oc " rep movsl\n" - | Psbbl_rr (res,a1) -> - fprintf oc " sbbl %a, %a\n" ireg32 a1 ireg32 res - | Psqrtsd (res,a1) -> - fprintf oc " sqrtsd %a, %a\n" freg a1 freg res - | Psubl_ri (res,n) -> - fprintf oc " subl $%ld, %a\n" (camlint_of_coqint n) ireg32 res; - | Psubq_ri (res,n) -> - fprintf oc " subq %a, %a\n" intconst64 n ireg64 res; - (* Pseudo-instructions *) - | Plabel(l) -> - fprintf oc "%a:\n" label (transl_label l) - | Pallocframe(sz, ofs_ra, ofs_link) - | Pfreeframe(sz, ofs_ra, ofs_link) -> - assert false - | Pbuiltin(ef, args, res) -> - begin match ef with - | EF_annot(txt, targs) -> - fprintf oc "%s annotation: " comment; - print_annot_text preg "%esp" oc (camlstring_of_coqstring txt) args - | EF_debug(kind, txt, targs) -> - print_debug_info comment print_file_line preg "%esp" oc - (P.to_int kind) (extern_atom txt) args - | EF_inline_asm(txt, sg, clob) -> - fprintf oc "%s begin inline assembly\n\t" comment; - print_inline_asm preg oc (camlstring_of_coqstring txt) sg args res; - fprintf oc "%s end inline assembly\n" comment - | _ -> - assert false - end - - let print_literal64 oc (lbl, n) = - fprintf oc "%a: .quad 0x%Lx\n" label lbl n - let print_literal32 oc (lbl, n) = - fprintf oc "%a: .long 0x%lx\n" label lbl n - - let print_jumptable oc jmptbl = - let print_jumptable (lbl, tbl) = - let print_entry l = - if Archi.ptr64 then - fprintf oc " .long %a - %a\n" label (transl_label l) label lbl - else - fprintf oc " .long %a\n" label (transl_label l) - in - fprintf oc "%a:" label lbl; - List.iter print_entry tbl - in - if !jumptables <> [] then begin - section oc jmptbl; - print_align oc 4; - List.iter print_jumptable !jumptables; - jumptables := [] - end - - let print_init oc = function - | Init_int8 n -> - fprintf oc " .byte %ld\n" (camlint_of_coqint n) - | Init_int16 n -> - fprintf oc " .short %ld\n" (camlint_of_coqint n) - | Init_int32 n -> - fprintf oc " .long %ld\n" (camlint_of_coqint n) - | Init_int64 n -> - fprintf oc " .quad %Ld\n" (camlint64_of_coqint n) - | Init_float32 n -> - fprintf oc " .long %ld %s %.18g\n" - (camlint_of_coqint (Floats.Float32.to_bits n)) - comment (camlfloat_of_coqfloat32 n) - | Init_float64 n -> - fprintf oc " .quad %Ld %s %.18g\n" - (camlint64_of_coqint (Floats.Float.to_bits n)) - comment (camlfloat_of_coqfloat n) - | Init_space n -> - if Z.gt n Z.zero then - fprintf oc " .space %a\n" z n - | Init_addrof(symb, ofs) -> - fprintf oc " %s %a\n" data_pointer symbol_offset (symb, ofs) - - let print_align = print_align - - let print_comm_symb oc sz name align = - if C2C.atom_is_static name - then System.print_lcomm_decl oc name sz align - else System.print_comm_decl oc name sz align - - let name_of_section = name_of_section - - let emit_constants oc lit = - if !float64_literals <> [] || !float32_literals <> [] then begin - section oc lit; - print_align oc 8; - List.iter (print_literal64 oc) !float64_literals; - float64_literals := []; - List.iter (print_literal32 oc) !float32_literals; - float32_literals := [] - end - - let cfi_startproc = cfi_startproc - let cfi_endproc = cfi_endproc - - let print_instructions oc fn = - current_function_sig := fn.fn_sig; - List.iter (print_instruction oc) fn.fn_code - - let print_optional_fun_info _ = () - - let get_section_names name = - match C2C.atom_sections name with - | [t;l;j] -> (t, l, j) - | _ -> (Section_text, Section_literal, Section_jumptable) - - let reset_constants = reset_constants - - let print_fun_info = print_fun_info - - let print_var_info = print_var_info - - let print_prologue oc = - need_masks := false; - if !Clflags.option_g then begin - section oc Section_text; - if Configuration.system <> "bsd" then cfi_section oc - end - - let print_epilogue oc = - if !need_masks then begin - section oc (Section_const true); - (* not Section_literal because not 8-bytes *) - print_align oc 16; - fprintf oc "%a: .quad 0x8000000000000000, 0\n" - raw_symbol "__negd_mask"; - fprintf oc "%a: .quad 0x7FFFFFFFFFFFFFFF, 0xFFFFFFFFFFFFFFFF\n" - raw_symbol "__absd_mask"; - fprintf oc "%a: .long 0x80000000, 0, 0, 0\n" - raw_symbol "__negs_mask"; - fprintf oc "%a: .long 0x7FFFFFFF, 0xFFFFFFFF, 0xFFFFFFFF, 0xFFFFFFFF\n" - raw_symbol "__abss_mask" - end; - System.print_epilogue oc; - if !Clflags.option_g then begin - Debug.compute_gnu_file_enum (fun f -> ignore (print_file oc f)); - section oc Section_text; - end - - let comment = comment - - let default_falignment = 16 - - let label = label - - let new_label = new_label - -end - -let sel_target () = - let module S = (val (match Configuration.system with - | "macosx" -> (module MacOS_System:SYSTEM) - | "linux" - | "bsd" -> (module ELF_System:SYSTEM) - | _ -> invalid_arg ("System " ^ Configuration.system ^ " not supported") ):SYSTEM) in - (module Target(S):TARGET) diff --git a/ia32/ValueAOp.v b/ia32/ValueAOp.v deleted file mode 100644 index 98f0dbb1..00000000 --- a/ia32/ValueAOp.v +++ /dev/null @@ -1,266 +0,0 @@ -(* *********************************************************************) -(* *) -(* 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. - -Local Transparent Archi.ptr64. - -(** Value analysis for x86_64 operators *) - -Definition eval_static_condition (cond: condition) (vl: list aval): abool := - match cond, vl with - | Ccomp c, v1 :: v2 :: nil => cmp_bool c v1 v2 - | Ccompu c, v1 :: v2 :: nil => cmpu_bool c v1 v2 - | Ccompimm c n, v1 :: nil => cmp_bool c v1 (I n) - | Ccompuimm c n, v1 :: nil => cmpu_bool c v1 (I n) - | Ccompl c, v1 :: v2 :: nil => cmpl_bool c v1 v2 - | Ccomplu c, v1 :: v2 :: nil => cmplu_bool c v1 v2 - | Ccomplimm c n, v1 :: nil => cmpl_bool c v1 (L n) - | Ccompluimm c n, v1 :: nil => cmplu_bool c v1 (L n) - | Ccompf c, v1 :: v2 :: nil => cmpf_bool c v1 v2 - | Cnotcompf c, v1 :: v2 :: nil => cnot (cmpf_bool c v1 v2) - | Ccompfs c, v1 :: v2 :: nil => cmpfs_bool c v1 v2 - | Cnotcompfs c, v1 :: v2 :: nil => cnot (cmpfs_bool c v1 v2) - | Cmaskzero n, v1 :: nil => maskzero v1 n - | Cmasknotzero n, v1 :: nil => cnot (maskzero v1 n) - | _, _ => Bnone - end. - -Definition eval_static_addressing_32 (addr: addressing) (vl: list aval): aval := - match addr, vl with - | Aindexed n, v1::nil => add v1 (I (Int.repr n)) - | Aindexed2 n, v1::v2::nil => add (add v1 v2) (I (Int.repr n)) - | Ascaled sc ofs, v1::nil => add (mul v1 (I (Int.repr sc))) (I (Int.repr ofs)) - | Aindexed2scaled sc ofs, v1::v2::nil => add v1 (add (mul v2 (I (Int.repr sc))) (I (Int.repr ofs))) - | Aglobal s ofs, nil => Ptr (Gl s ofs) - | Abased s ofs, v1::nil => add (Ptr (Gl s ofs)) v1 - | Abasedscaled sc s ofs, v1::nil => add (Ptr (Gl s ofs)) (mul v1 (I (Int.repr sc))) - | Ainstack ofs, nil => Ptr(Stk ofs) - | _, _ => Vbot - end. - -Definition eval_static_addressing_64 (addr: addressing) (vl: list aval): aval := - match addr, vl with - | Aindexed n, v1::nil => addl v1 (L (Int64.repr n)) - | Aindexed2 n, v1::v2::nil => addl (addl v1 v2) (L (Int64.repr n)) - | Ascaled sc ofs, v1::nil => addl (mull v1 (L (Int64.repr sc))) (L (Int64.repr ofs)) - | Aindexed2scaled sc ofs, v1::v2::nil => addl v1 (addl (mull v2 (L (Int64.repr sc))) (L (Int64.repr ofs))) - | Aglobal s ofs, nil => Ptr (Gl s ofs) - | Abased s ofs, v1::nil => addl (Ptr (Gl s ofs)) v1 - | Abasedscaled sc s ofs, v1::nil => addl (Ptr (Gl s ofs)) (mull v1 (L (Int64.repr sc))) - | Ainstack ofs, nil => Ptr(Stk ofs) - | _, _ => Vbot - end. - -Definition eval_static_addressing (addr: addressing) (vl: list aval): aval := - if Archi.ptr64 - then eval_static_addressing_64 addr vl - else eval_static_addressing_32 addr vl. - -Definition eval_static_operation (op: operation) (vl: list aval): aval := - match op, vl with - | Omove, v1::nil => v1 - | Ointconst n, nil => I n - | Olongconst n, nil => L n - | Ofloatconst n, nil => if propagate_float_constants tt then F n else ntop - | Osingleconst n, nil => if propagate_float_constants tt then FS n else ntop - | Oindirectsymbol id, nil => Ifptr (Gl id Ptrofs.zero) - | Ocast8signed, v1 :: nil => sign_ext 8 v1 - | Ocast8unsigned, v1 :: nil => zero_ext 8 v1 - | Ocast16signed, v1 :: nil => sign_ext 16 v1 - | Ocast16unsigned, v1 :: nil => zero_ext 16 v1 - | Oneg, v1::nil => neg v1 - | Osub, v1::v2::nil => sub v1 v2 - | Omul, v1::v2::nil => mul v1 v2 - | Omulimm n, v1::nil => mul v1 (I n) - | Omulhs, v1::v2::nil => mulhs v1 v2 - | Omulhu, v1::v2::nil => mulhu v1 v2 - | Odiv, v1::v2::nil => divs v1 v2 - | Odivu, v1::v2::nil => divu v1 v2 - | Omod, v1::v2::nil => mods v1 v2 - | Omodu, v1::v2::nil => modu v1 v2 - | Oand, v1::v2::nil => and v1 v2 - | Oandimm n, v1::nil => and v1 (I n) - | Oor, v1::v2::nil => or v1 v2 - | Oorimm n, v1::nil => or v1 (I n) - | Oxor, v1::v2::nil => xor v1 v2 - | Oxorimm n, v1::nil => xor v1 (I n) - | Onot, v1::nil => notint v1 - | Oshl, v1::v2::nil => shl v1 v2 - | Oshlimm n, v1::nil => shl v1 (I n) - | Oshr, v1::v2::nil => shr v1 v2 - | Oshrimm n, v1::nil => shr v1 (I n) - | Oshrximm n, v1::nil => shrx v1 (I n) - | Oshru, v1::v2::nil => shru v1 v2 - | Oshruimm n, v1::nil => shru v1 (I n) - | Ororimm n, v1::nil => ror v1 (I n) - | Oshldimm n, v1::v2::nil => or (shl v1 (I n)) (shru v2 (I (Int.sub Int.iwordsize n))) - | Olea addr, _ => eval_static_addressing_32 addr vl - | Omakelong, v1::v2::nil => longofwords v1 v2 - | Olowlong, v1::nil => loword v1 - | Ohighlong, v1::nil => hiword v1 - | Ocast32signed, v1::nil => longofint v1 - | Ocast32unsigned, v1::nil => longofintu v1 - | Onegl, v1::nil => negl v1 - | Oaddlimm n, v1::nil => addl v1 (L n) - | Osubl, v1::v2::nil => subl v1 v2 - | Omull, v1::v2::nil => mull v1 v2 - | Omullimm n, v1::nil => mull v1 (L n) - | Omullhs, v1::v2::nil => mullhs v1 v2 - | Omullhu, v1::v2::nil => mullhu v1 v2 - | Odivl, v1::v2::nil => divls v1 v2 - | Odivlu, v1::v2::nil => divlu v1 v2 - | Omodl, v1::v2::nil => modls v1 v2 - | Omodlu, v1::v2::nil => modlu v1 v2 - | Oandl, v1::v2::nil => andl v1 v2 - | Oandlimm n, v1::nil => andl v1 (L n) - | Oorl, v1::v2::nil => orl v1 v2 - | Oorlimm n, v1::nil => orl v1 (L n) - | Oxorl, v1::v2::nil => xorl v1 v2 - | Oxorlimm n, v1::nil => xorl v1 (L n) - | Onotl, v1::nil => notl v1 - | Oshll, v1::v2::nil => shll v1 v2 - | Oshllimm n, v1::nil => shll v1 (I n) - | Oshrl, v1::v2::nil => shrl v1 v2 - | Oshrlimm n, v1::nil => shrl v1 (I n) - | Oshrxlimm n, v1::nil => shrxl v1 (I n) - | Oshrlu, v1::v2::nil => shrlu v1 v2 - | Oshrluimm n, v1::nil => shrlu v1 (I n) - | Ororlimm n, v1::nil => rorl v1 (I n) - | Oleal addr, _ => eval_static_addressing_64 addr vl - | Onegf, v1::nil => negf v1 - | Oabsf, v1::nil => absf v1 - | Oaddf, v1::v2::nil => addf v1 v2 - | Osubf, v1::v2::nil => subf v1 v2 - | Omulf, v1::v2::nil => mulf v1 v2 - | Odivf, v1::v2::nil => divf v1 v2 - | Onegfs, v1::nil => negfs v1 - | Oabsfs, v1::nil => absfs v1 - | Oaddfs, v1::v2::nil => addfs v1 v2 - | Osubfs, v1::v2::nil => subfs v1 v2 - | Omulfs, v1::v2::nil => mulfs v1 v2 - | Odivfs, v1::v2::nil => divfs v1 v2 - | Osingleoffloat, v1::nil => singleoffloat v1 - | Ofloatofsingle, v1::nil => floatofsingle v1 - | Ointoffloat, v1::nil => intoffloat v1 - | Ofloatofint, v1::nil => floatofint v1 - | Ointofsingle, v1::nil => intofsingle v1 - | Osingleofint, v1::nil => singleofint v1 - | Olongoffloat, v1::nil => longoffloat v1 - | Ofloatoflong, v1::nil => floatoflong v1 - | Olongofsingle, v1::nil => longofsingle v1 - | Osingleoflong, v1::nil => singleoflong v1 - | Ocmp c, _ => of_optbool (eval_static_condition c vl) - | _, _ => Vbot - end. - -Section SOUNDNESS. - -Variable bc: block_classification. -Variable ge: genv. -Hypothesis GENV: genv_match bc ge. -Variable sp: block. -Hypothesis STACK: bc sp = BCstack. - -Theorem eval_static_condition_sound: - forall cond vargs m aargs, - list_forall2 (vmatch bc) vargs aargs -> - cmatch (eval_condition cond vargs m) (eval_static_condition cond aargs). -Proof. - intros until aargs; intros VM. inv VM. - destruct cond; auto with va. - inv H0. - destruct cond; simpl; eauto with va. - inv H2. - destruct cond; simpl; eauto with va. - destruct cond; auto with va. -Qed. - -Lemma symbol_address_sound: - forall id ofs, - vmatch bc (Genv.symbol_address ge id ofs) (Ptr (Gl id ofs)). -Proof. - intros; apply symbol_address_sound; apply GENV. -Qed. - -Lemma symbol_address_sound_2: - forall id ofs, - vmatch bc (Genv.symbol_address ge id ofs) (Ifptr (Gl id ofs)). -Proof. - intros. unfold Genv.symbol_address. destruct (Genv.find_symbol ge id) as [b|] eqn:F. - constructor. constructor. apply GENV; auto. - constructor. -Qed. - -Hint Resolve symbol_address_sound symbol_address_sound_2: va. - -Ltac InvHyps := - match goal with - | [H: None = Some _ |- _ ] => discriminate - | [H: Some _ = Some _ |- _] => inv H - | [H1: match ?vl with nil => _ | _ :: _ => _ end = Some _ , - H2: list_forall2 _ ?vl _ |- _ ] => inv H2; InvHyps - | [H: (if Archi.ptr64 then _ else _) = Some _ |- _] => destruct Archi.ptr64 eqn:?; InvHyps - | _ => idtac - end. - -Theorem eval_static_addressing_32_sound: - forall addr vargs vres aargs, - eval_addressing32 ge (Vptr sp Ptrofs.zero) addr vargs = Some vres -> - list_forall2 (vmatch bc) vargs aargs -> - vmatch bc vres (eval_static_addressing_32 addr aargs). -Proof. - unfold eval_addressing32, eval_static_addressing_32; intros; - destruct addr; InvHyps; eauto with va. - rewrite Ptrofs.add_zero_l; eauto with va. -Qed. - -Theorem eval_static_addressing_64_sound: - forall addr vargs vres aargs, - eval_addressing64 ge (Vptr sp Ptrofs.zero) addr vargs = Some vres -> - list_forall2 (vmatch bc) vargs aargs -> - vmatch bc vres (eval_static_addressing_64 addr aargs). -Proof. - unfold eval_addressing64, eval_static_addressing_64; intros; - destruct addr; InvHyps; eauto with va. - rewrite Ptrofs.add_zero_l; eauto with va. -Qed. - -Theorem eval_static_addressing_sound: - forall addr vargs vres aargs, - eval_addressing ge (Vptr sp Ptrofs.zero) addr vargs = Some vres -> - list_forall2 (vmatch bc) vargs aargs -> - vmatch bc vres (eval_static_addressing addr aargs). -Proof. - unfold eval_addressing, eval_static_addressing; intros. - destruct Archi.ptr64; eauto using eval_static_addressing_32_sound, eval_static_addressing_64_sound. -Qed. - -Theorem eval_static_operation_sound: - forall op vargs m vres aargs, - eval_operation ge (Vptr sp Ptrofs.zero) op vargs m = Some vres -> - list_forall2 (vmatch bc) vargs aargs -> - vmatch bc vres (eval_static_operation op aargs). -Proof. - unfold eval_operation, eval_static_operation; intros; - destruct op; InvHyps; eauto with va. - destruct (propagate_float_constants tt); constructor. - destruct (propagate_float_constants tt); constructor. - eapply eval_static_addressing_32_sound; eauto. - eapply eval_static_addressing_64_sound; eauto. - apply of_optbool_sound. eapply eval_static_condition_sound; eauto. -Qed. - -End SOUNDNESS. - diff --git a/ia32/extractionMachdep.v b/ia32/extractionMachdep.v deleted file mode 100644 index 8b395579..00000000 --- a/ia32/extractionMachdep.v +++ /dev/null @@ -1,31 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(* Additional extraction directives specific to the x86-64 port *) - -Require Archi SelectOp ConstpropOp. - -(* Archi *) - -Extract Constant Archi.ptr64 => - "Configuration.model = ""64"" ". - -(* 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". - |