From a14b9578ee5297d954103e05d7b2d322816ddd8f Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Sat, 1 Oct 2016 17:38:24 +0200 Subject: Support for 64-bit architectures: x86 in 64-bit mode This commit enriches the IA32 port so that it supports x86 processors in 64-bit mode as well as in 32-bit mode, depending on the value of Archi.ptr64, which itself is set from the configuration model. To activate x86-64 bit support, configure with "x86_64-linux". Main steps: - Enrich Op.v and Asm.v with 64-bit operations - SelectLong: in 64-bit mode, use 64-bit operations directly; in 32-bit mode, fall back on the old implementation based on pairs of 32-bit integers - Conventions1: support x86-64 ABI in addition to the 32-bit ABI. - Add support for the new 64-bit operations everywhere. - runtime/x86_64: implementation of the supporting library appropriate for x86 in 64-bit mode To do: - More optimizations are possible on 64-bit integer arithmetic operations. - Could add new chunks to load, say, an unsigned byte into a 64-bit long (currently we load as a 32-bit int then zero-extend). - Implements the wrong ABI for struct passing. --- ia32/Archi.v | 19 +- ia32/Asm.v | 543 ++++++++++++++++++---------- ia32/Asmexpand.ml | 367 ++++++++++++------- ia32/Asmgen.v | 350 ++++++++++++------ ia32/Asmgenproof.v | 116 +++--- ia32/Asmgenproof1.v | 751 +++++++++++++++++++++++++-------------- ia32/CBuiltins.ml | 9 +- ia32/CombineOp.v | 49 ++- ia32/CombineOpproof.v | 48 ++- ia32/ConstpropOp.vp | 226 ++++++++++-- ia32/ConstpropOpproof.v | 499 +++++++++++++++++++++----- ia32/Conventions1.v | 331 +++++++++++++++--- ia32/Machregs.v | 111 ++++-- ia32/NeedOp.v | 116 ++++-- ia32/Op.v | 895 +++++++++++++++++++++++++++++++++-------------- ia32/PrintOp.ml | 70 +++- ia32/SelectLong.vp | 365 +++++++++++++++++++ ia32/SelectLongproof.v | 304 ++++++++++++++++ ia32/SelectOp.vp | 79 +++-- ia32/SelectOpproof.v | 153 +++++--- ia32/Stacklayout.v | 70 ++-- ia32/TargetPrinter.ml | 508 +++++++++++++++------------ ia32/ValueAOp.v | 133 +++++-- ia32/extractionMachdep.v | 15 +- 24 files changed, 4506 insertions(+), 1621 deletions(-) create mode 100644 ia32/SelectLong.vp create mode 100644 ia32/SelectLongproof.v (limited to 'ia32') diff --git a/ia32/Archi.v b/ia32/Archi.v index ded460d2..936bacb3 100644 --- a/ia32/Archi.v +++ b/ia32/Archi.v @@ -2,8 +2,8 @@ (* *) (* The Compcert verified compiler *) (* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* Jacques-Henri Jourdan, INRIA Paris-Rocquencourt *) +(* 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 *) @@ -20,10 +20,19 @@ Require Import ZArith. Require Import Fappli_IEEE. Require Import Fappli_IEEE_bits. +Parameter ptr64: bool. + Definition big_endian := false. -Notation align_int64 := 4%Z (only parsing). -Notation align_float64 := 4%Z (only parsing). +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). @@ -39,7 +48,7 @@ Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_p Definition float_of_single_preserves_sNaN := false. -Global Opaque big_endian +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 index b4fc950b..01ecb15a 100644 --- a/ia32/Asm.v +++ b/ia32/Asm.v @@ -2,7 +2,7 @@ (* *) (* The Compcert verified compiler *) (* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Xavier Leroy, INRIA Paris *) (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) @@ -12,19 +12,9 @@ (** Abstract syntax and semantics for IA32 assembly language *) -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Locations. -Require Import Stacklayout. -Require Import Conventions. +Require Import Coqlib Maps. +Require Import AST Integers Floats Values Memory Events Globalenvs Smallstep. +Require Import Locations Stacklayout Conventions. (** * Abstract syntax *) @@ -33,14 +23,14 @@ Require Import Conventions. (** Integer registers. *) Inductive ireg: Type := - | EAX: ireg | EBX: ireg | ECX: ireg | EDX: ireg - | ESI: ireg | EDI: ireg | EBP: ireg | ESP: ireg. + | 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: freg | XMM1: freg | XMM2: freg | XMM3: freg - | XMM4: freg | XMM5: freg | XMM6: freg | XMM7: freg. + | 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. @@ -69,7 +59,7 @@ Coercion CR: crbit >-> preg. (** Conventional names for stack pointer ([SP]) and return address ([RA]) *) -Notation SP := ESP (only parsing). +Notation SP := RSP (only parsing). (** ** Instruction set. *) @@ -79,8 +69,8 @@ Definition label := positive. Inductive addrmode: Type := | Addrmode (base: option ireg) - (ofs: option (ireg * int)) - (const: int + ident * int). + (ofs: option (ireg * Z)) + (const: Z + ident * ptrofs). (** Testable conditions (for conditional jumps and more). *) @@ -94,7 +84,15 @@ Inductive testcond: Type := registers, memory references and immediate constants as arguments. Here, we list only the combinations that we actually use. - Naming conventions: + 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 @@ -109,11 +107,14 @@ Inductive testcond: Type := Inductive instruction: Type := (** Moves *) - | Pmov_rr (rd: ireg) (r1: ireg) (**r [mov] (32-bit int) *) - | Pmov_ri (rd: ireg) (n: int) - | Pmov_ra (rd: ireg) (id: ident) - | Pmov_rm (rd: ireg) (a: addrmode) - | Pmov_mr (a: addrmode) (rs: ireg) + | 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) @@ -125,7 +126,6 @@ Inductive instruction: Type := | Pfstpl_m (a: addrmode) (**r [fstp] double precision *) | Pflds_m (a: addrmode) (**r [fld] simple precision *) | Pfstps_m (a: addrmode) (**r [fstp] simple precision *) - | Pxchg_rr (r1: ireg) (r2: ireg) (**r register-register exchange *) (** 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) *) @@ -137,43 +137,81 @@ Inductive instruction: Type := | 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 *) - | Plea (rd: ireg) (a: addrmode) - | Pneg (rd: ireg) - | Psub_rr (rd: ireg) (r1: ireg) - | Pimul_rr (rd: ireg) (r1: ireg) - | Pimul_ri (rd: ireg) (n: int) - | Pimul_r (r1: ireg) - | Pmul_r (r1: ireg) + | 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 - | Pdiv (r1: ireg) - | Pidiv (r1: ireg) - | Pand_rr (rd: ireg) (r1: ireg) - | Pand_ri (rd: ireg) (n: int) - | Por_rr (rd: ireg) (r1: ireg) - | Por_ri (rd: ireg) (n: int) - | Pxor_r (rd: ireg) (**r [xor] with self = set to zero *) - | Pxor_rr (rd: ireg) (r1: ireg) - | Pxor_ri (rd: ireg) (n: int) - | Pnot (rd: ireg) - | Psal_rcl (rd: ireg) - | Psal_ri (rd: ireg) (n: int) - | Pshr_rcl (rd: ireg) - | Pshr_ri (rd: ireg) (n: int) - | Psar_rcl (rd: ireg) - | Psar_ri (rd: ireg) (n: int) + | 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) - | Pror_ri (rd: ireg) (n: int) - | Pcmp_rr (r1 r2: ireg) - | Pcmp_ri (r1: ireg) (n: int) - | Ptest_rr (r1 r2: ireg) - | Ptest_ri (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 *) @@ -204,24 +242,26 @@ Inductive instruction: Type := | Pcall_r (r: ireg) (sg: signature) | Pret (** Saving and restoring registers *) - | Pmov_rm_a (rd: ireg) (a: addrmode) (**r like [Pmov_rm], using [Many32] chunk *) - | Pmov_mr_a (a: addrmode) (rs: ireg) (**r like [Pmov_mr], using [Many32] chunk *) + | 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: int) - | Pfreeframe(sz: Z)(ofs_ra ofs_link: int) + | 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] *) - | Padc_ri (rd: ireg) (n: int) - | Padc_rr (rd: ireg) (r2: ireg) - | Padd_mi (a: addrmode) (n: int) - | Padd_ri (rd: ireg) (n: int) - | Padd_rr (rd: ireg) (r2: ireg) - | Pbsf (rd: ireg) (r1: ireg) - | Pbsr (rd: ireg) (r1: ireg) - | Pbswap (rd: ireg) + (** 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) @@ -239,15 +279,16 @@ Inductive instruction: Type := | Pmaxsd (rd: freg) (r2: freg) | Pminsd (rd: freg) (r2: freg) | Pmovb_rm (rd: ireg) (a: addrmode) - | Pmovq_mr (a: addrmode) (rs: freg) - | Pmovq_rm (rd: freg) (a: addrmode) + | Pmovsq_mr (a: addrmode) (rs: freg) + | Pmovsq_rm (rd: freg) (a: addrmode) | Pmovsb | Pmovsw | Pmovw_rm (rd: ireg) (ad: addrmode) | Prep_movsl - | Psbb_rr (rd: ireg) (r2: ireg) + | Psbbl_rr (rd: ireg) (r2: ireg) | Psqrtsd (rd: freg) (r1: freg) - | Psub_ri (rd: ireg) (n: int). + | 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 }. @@ -334,22 +375,44 @@ Variable ge: genv. (** Evaluating an addressing mode *) -Definition eval_addrmode (a: addrmode) (rs: regset) : val := - match a with Addrmode base ofs const => - Val.add (match base with - | None => Vzero - | Some r => rs r +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) - (Val.add (match ofs with - | None => Vzero - | Some(r, sc) => - if Int.eq sc Int.one then rs r else Val.mul (rs r) (Vint sc) - end) - (match const with - | inl ofs => Vint ofs - | inr(id, ofs) => Genv.symbol_address ge id ofs - end)) - 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 *) @@ -368,6 +431,13 @@ Definition compare_ints (x y: val) (rs: regset) (m: mem): regset := #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 @@ -481,7 +551,7 @@ Inductive outcome: Type := to [Vundef] in addition to incrementing the [PC]. *) Definition nextinstr (rs: regset) := - rs#PC <- (Val.add rs#PC Vone). + 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). @@ -491,7 +561,7 @@ Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) := | None => Stuck | Some pos => match rs#PC with - | Vptr b ofs => Next (rs#PC <- (Vptr b (Int.repr pos))) m + | Vptr b ofs => Next (rs#PC <- (Vptr b (Ptrofs.repr pos))) m | _ => Stuck end end. @@ -537,14 +607,20 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out (** Moves *) | Pmov_rr rd r1 => Next (nextinstr (rs#rd <- (rs r1))) m - | Pmov_ri rd n => + | Pmovl_ri rd n => Next (nextinstr_nf (rs#rd <- (Vint n))) m - | Pmov_ra rd id => - Next (nextinstr_nf (rs#rd <- (Genv.symbol_address ge id Int.zero))) m - | Pmov_rm rd a => + | 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 - | Pmov_mr a r1 => + | 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 => @@ -567,8 +643,6 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out exec_load Mfloat32 m a rs ST0 | Pfstps_m a => exec_store Mfloat32 m a rs ST0 (ST0 :: nil) - | Pxchg_rr r1 r2 => - Next (nextinstr (rs#r1 <- (rs r2) #r2 <- (rs r1))) m (** Moves with conversion *) | Pmovb_mr a r1 => exec_store Mint8unsigned m a rs r1 nil @@ -590,6 +664,12 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out 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 => @@ -602,85 +682,165 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out 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 *) - | Plea rd a => - Next (nextinstr (rs#rd <- (eval_addrmode a rs))) m - | Pneg rd => + | 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 - | Psub_rr rd r1 => + | 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 - | Pimul_rr rd r1 => + | 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 - | Pimul_ri rd n => + | 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 - | Pimul_r r1 => - Next (nextinstr_nf (rs#EAX <- (Val.mul rs#EAX rs#r1) - #EDX <- (Val.mulhs rs#EAX rs#r1))) m - | Pmul_r r1 => - Next (nextinstr_nf (rs#EAX <- (Val.mul rs#EAX rs#r1) - #EDX <- (Val.mulhu rs#EAX rs#r1))) 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 + | Pmull_r r1 => + Next (nextinstr_nf (rs#RAX <- (Val.mul rs#RAX rs#r1) + #RDX <- (Val.mulhu rs#RAX rs#r1))) m | Pcltd => - Next (nextinstr_nf (rs#EDX <- (Val.shr rs#EAX (Vint (Int.repr 31))))) m - | Pdiv r1 => - match rs#EDX, rs#EAX, rs#r1 with + 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#EAX <- (Vint q) #EDX <- (Vint r))) m + | Some(q, r) => Next (nextinstr_nf (rs#RAX <- (Vint q) #RDX <- (Vint r))) m | None => Stuck end | _, _, _ => Stuck end - | Pidiv r1 => - match rs#EDX, rs#EAX, rs#r1 with + | 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#EAX <- (Vint q) #EDX <- (Vint r))) m + | 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 - | Pand_rr rd r1 => + | Pandl_rr rd r1 => Next (nextinstr_nf (rs#rd <- (Val.and rs#rd rs#r1))) m - | Pand_ri rd n => + | 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 - | Por_rr rd r1 => + | 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 - | Por_ri rd n => + | 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 - | Pxor_r rd => + | 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 - | Pxor_rr rd r1 => + | 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 - | Pxor_ri rd n => + | 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 - | Pnot rd => + | 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 - | Psal_rcl rd => - Next (nextinstr_nf (rs#rd <- (Val.shl rs#rd rs#ECX))) m - | Psal_ri rd n => + | 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 - | Pshr_rcl rd => - Next (nextinstr_nf (rs#rd <- (Val.shru rs#rd rs#ECX))) m - | Pshr_ri rd n => + | 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 - | Psar_rcl rd => - Next (nextinstr_nf (rs#rd <- (Val.shr rs#rd rs#ECX))) m - | Psar_ri rd n => + | 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 - | Pror_ri rd n => + | Prorl_ri rd n => Next (nextinstr_nf (rs#rd <- (Val.ror rs#rd (Vint n)))) m - | Pcmp_rr r1 r2 => + | 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 - | Pcmp_ri r1 n => + | 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 - | Ptest_rr r1 r2 => + | 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 - | Ptest_ri r1 n => + | 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 @@ -727,7 +887,7 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pjmp_l lbl => goto_label f lbl rs m | Pjmp_s id sg => - Next (rs#PC <- (Genv.symbol_address ge id Int.zero)) m + Next (rs#PC <- (Genv.symbol_address ge id Ptrofs.zero)) m | Pjmp_r r sg => Next (rs#PC <- (rs r)) m | Pjcc cond lbl => @@ -752,16 +912,16 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | _ => Stuck end | Pcall_s id sg => - Next (rs#RA <- (Val.add rs#PC Vone) #PC <- (Genv.symbol_address ge id Int.zero)) m + 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.add rs#PC Vone) #PC <- (rs r)) m + 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 Many32 m a rs rd + exec_load (if Archi.ptr64 then Many64 else Many32) m a rs rd | Pmov_mr_a a r1 => - exec_store Many32 m a rs r1 nil + 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 => @@ -771,27 +931,27 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr rs) m | Pallocframe sz ofs_ra ofs_link => let (m1, stk) := Mem.alloc m 0 sz in - let sp := Vptr stk Int.zero in - match Mem.storev Mint32 m1 (Val.add sp (Vint ofs_link)) rs#ESP with + 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 Mint32 m2 (Val.add sp (Vint ofs_ra)) rs#RA with + match Mem.storev Mptr m2 (Val.offset_ptr sp ofs_ra) rs#RA with | None => Stuck - | Some m3 => Next (nextinstr (rs #EDX <- (rs#ESP) #ESP <- sp)) m3 + | Some m3 => Next (nextinstr (rs #RAX <- (rs#RSP) #RSP <- sp)) m3 end end | Pfreeframe sz ofs_ra ofs_link => - match Mem.loadv Mint32 m (Val.add rs#ESP (Vint ofs_ra)) with + match Mem.loadv Mptr m (Val.offset_ptr rs#RSP ofs_ra) with | None => Stuck | Some ra => - match Mem.loadv Mint32 m (Val.add rs#ESP (Vint ofs_link)) with + match Mem.loadv Mptr m (Val.offset_ptr rs#RSP ofs_link) with | None => Stuck | Some sp => - match rs#ESP with + match rs#RSP with | Vptr stk ofs => match Mem.free m stk 0 sz with | None => Stuck - | Some m' => Next (nextinstr (rs#ESP <- sp #RA <- ra)) m' + | Some m' => Next (nextinstr (rs#RSP <- sp #RA <- ra)) m' end | _ => Stuck end @@ -801,14 +961,16 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Stuck (**r treated specially below *) (** The following instructions and directives are not generated directly by [Asmgen], so we do not model them. *) - | Padc_ri _ _ - | Padc_rr _ _ - | Padd_mi _ _ - | Padd_ri _ _ - | Padd_rr _ _ - | Pbsf _ _ - | Pbsr _ _ - | Pbswap _ + | Padcl_ri _ _ + | Padcl_rr _ _ + | Paddl_mi _ _ + | Paddl_rr _ _ + | Pbsfl _ _ + | Pbsfq _ _ + | Pbsrl _ _ + | Pbsrq _ _ + | Pbswap64 _ + | Pbswap32 _ | Pbswap16 _ | Pcfi_adjust _ | Pfmadd132 _ _ _ @@ -826,15 +988,16 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pmaxsd _ _ | Pminsd _ _ | Pmovb_rm _ _ - | Pmovq_rm _ _ - | Pmovq_mr _ _ + | Pmovsq_rm _ _ + | Pmovsq_mr _ _ | Pmovsb | Pmovsw | Pmovw_rm _ _ | Prep_movsl - | Psbb_rr _ _ + | Psbbl_rr _ _ | Psqrtsd _ _ - | Psub_ri _ _ => Stuck + | Psubl_ri _ _ + | Psubq_ri _ _ => Stuck end. (** Translation of the LTL/Linear/Mach view of machine registers @@ -842,13 +1005,21 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Definition preg_of (r: mreg) : preg := match r with - | AX => IR EAX - | BX => IR EBX - | CX => IR ECX - | DX => IR EDX - | SI => IR ESI - | DI => IR EDI - | BP => IR EBP + | 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 @@ -857,6 +1028,14 @@ Definition preg_of (r: mreg) : preg := | 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. @@ -870,7 +1049,7 @@ Inductive extcall_arg (rs: regset) (m: mem): loc -> val -> Prop := | extcall_arg_stack: forall ofs ty bofs v, bofs = Stacklayout.fe_ofs_arg + 4 * ofs -> Mem.loadv (chunk_of_type ty) m - (Val.add (rs (IR ESP)) (Vint (Int.repr bofs))) = Some v -> + (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 := @@ -899,15 +1078,15 @@ Inductive step: state -> trace -> state -> Prop := 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 (Int.unsigned ofs) f.(fn_code) = Some i -> + 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 (Int.unsigned ofs) f.(fn_code) = Some (Pbuiltin ef args res) -> - eval_builtin_args ge rs (rs ESP) m args vargs -> + 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 @@ -915,7 +1094,7 @@ Inductive step: state -> trace -> state -> Prop := 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 Int.zero -> + 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' -> @@ -932,15 +1111,15 @@ Inductive initial_state (p: program): state -> Prop := let ge := Genv.globalenv p in let rs0 := (Pregmap.init Vundef) - # PC <- (Genv.symbol_address ge p.(prog_main) Int.zero) - # RA <- Vzero - # ESP <- Vzero in + # 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 = Vzero -> - rs#EAX = Vint r -> + rs#PC = Vnullptr -> + rs#RAX = Vint r -> final_state (State rs m) r. Definition semantics (p: program) := @@ -998,7 +1177,9 @@ Ltac Equalities := - (* initial states *) inv H; inv H0. f_equal. congruence. - (* final no step *) - inv H. unfold Vzero in H0. red; intros; red; intros. inv H; congruence. + 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. diff --git a/ia32/Asmexpand.ml b/ia32/Asmexpand.ml index 6a64221e..5c2a4bc9 100644 --- a/ia32/Asmexpand.ml +++ b/ia32/Asmexpand.ml @@ -19,38 +19,60 @@ open Asmexpandaux open AST open Camlcoq open Datatypes -open Integers exception Error of string (* Useful constants and helper functions *) -let _0 = Int.zero -let _1 = Int.one +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 () = - if Configuration.system = "macosx" then 16 - else 8 +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 int32_align n a = - if n >= 0l - then Int32.logand (Int32.add n (Int32.of_int (a-1))) (Int32.of_int (-a)) - else Int32.logand n (Int32.of_int (-a)) +let align n a = + if n >= 0 then (n + a - 1) land (-a) else n land (-a) -let sp_adjustment sz = - let sz = camlint_of_coqint sz in +let sp_adjustment_32 sz = + let sz = Z.to_int sz in (* Preserve proper alignment of the stack *) - let sz = int32_align sz (stack_alignment ()) in + let sz = align sz (stack_alignment ()) in (* The top 4 bytes have already been allocated by the "call" instruction. *) - let sz = Int32.sub sz 4l in - sz - - + 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; @@ -69,25 +91,25 @@ let expand_annot_val txt targ args res = | _, _ -> raise (Error "ill-formed __builtin_annot_intval") -(* Translate a builtin argument into an addressing mode *) - -let addressing_of_builtin_arg = function - | BA (IR r) -> Addrmode(Some r, None, Coq_inl Integers.Int.zero) - | BA_addrstack ofs -> Addrmode(Some ESP, None, Coq_inl ofs) - | BA_addrglobal(id, ofs) -> Addrmode(None, None, Coq_inr(id, ofs)) - | _ -> assert false - (* Operations on addressing modes *) let offset_addressing (Addrmode(base, ofs, cst)) delta = Addrmode(base, ofs, match cst with - | Coq_inl n -> Coq_inl(Int.add n delta) - | Coq_inr(id, n) -> Coq_inr(id, Int.add n delta)) + | 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 @@ -95,29 +117,34 @@ let global_addr id ofs = Addrmode(None, None, Coq_inr(id, ofs)) let expand_builtin_memcpy_small sz al src dst = let rec copy src dst sz = - if sz >= 8 && !Clflags.option_ffpu then begin - emit (Pmovq_rm (XMM7, src)); - emit (Pmovq_mr (dst, XMM7)); - copy (offset_addressing src _8) (offset_addressing dst _8) (sz - 8) + 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 (Pmov_rm (ECX, src)); - emit (Pmov_mr (dst, ECX)); - copy (offset_addressing src _4) (offset_addressing dst _4) (sz - 4) + 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 (ECX, src)); - emit (Pmovw_mr (dst, ECX)); - copy (offset_addressing src _2) (offset_addressing dst _2) (sz - 2) + 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 (ECX, src)); - emit (Pmovb_mr (dst, ECX)); - copy (offset_addressing src _1) (offset_addressing dst _1) (sz - 1) + 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 ESI) then emit (Plea (ESI, addressing_of_builtin_arg src)); - if dst <> BA (IR EDI) then emit (Plea (EDI, addressing_of_builtin_arg dst)); - emit (Pmov_ri (ECX,coqint_of_camlint (Int32.of_int (sz / 4)))); + 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 @@ -141,15 +168,17 @@ let expand_builtin_vload_common chunk addr res = | Mint16signed, BR(IR res) -> emit (Pmovsw_rm (res,addr)) | Mint32, BR(IR res) -> - emit (Pmov_rm (res,addr)) + 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 _4 in + let addr' = offset_addressing addr _4z in if not (Asmgen.addressing_mentions addr res2) then begin - emit (Pmov_rm (res2,addr)); - emit (Pmov_rm (res1,addr')) + emit (Pmovl_rm (res2,addr)); + emit (Pmovl_rm (res1,addr')) end else begin - emit (Pmov_rm (res1,addr')); - emit (Pmov_rm (res2,addr)) + emit (Pmovl_rm (res1,addr')); + emit (Pmovl_rm (res2,addr)) end | Mfloat32, BR(FR res) -> emit (Pmovss_fm (res,addr)) @@ -168,20 +197,22 @@ let expand_builtin_vload chunk args res = let expand_builtin_vstore_common chunk addr src tmp = match chunk, src with | (Mint8signed | Mint8unsigned), BA(IR src) -> - if Asmgen.low_ireg src then + 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 + 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 (Pmov_mr (addr,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 _4 in - emit (Pmov_mr (addr,src2)); - emit (Pmov_mr (addr',src1)) + 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) -> @@ -194,20 +225,65 @@ let expand_builtin_vstore chunk args = | [addr; src] -> let addr = addressing_of_builtin_arg addr in expand_builtin_vstore_common chunk addr src - (if Asmgen.addressing_mentions addr EAX then ECX else EAX) + (if Asmgen.addressing_mentions addr RAX then RCX else RAX) | _ -> assert false (* Handling of varargs *) -let expand_builtin_va_start r = +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 = coqint_of_camlint + let ofs = Int32.(add (add !PrintAsmaux.current_function_stacksize 4l) (mul 4l (Z.to_int32 (Conventions1.size_arguments (get_current_function_sig ()))))) in - emit (Pmov_mr (linear_addr r _0, ESP)); - emit (Padd_mi (linear_addr r _0, ofs)) + 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 *) @@ -239,38 +315,47 @@ let expand_builtin_inline name args res = | ("__builtin_bswap"| "__builtin_bswap32"), [BA(IR a1)], BR(IR res) -> if a1 <> res then emit (Pmov_rr (res,a1)); - emit (Pbswap res) + emit (Pbswap32 res) + | "__builtin_bswap64", [BA(IR a1)], BR(IR res) -> + if a1 <> res then + emit (Pmov_rr (res,a1)); + emit (Pbswap64 res) | "__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 (Pbsr (res,a1)); - emit (Pxor_ri(res,coqint_of_camlint 31l)) + 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 (Ptest_rr(ah, ah)); + emit (Ptestl_rr(ah, ah)); emit (Pjcc(Cond_e, lbl1)); - emit (Pbsr(res, ah)); - emit (Pxor_ri(res, coqint_of_camlint 31l)); + emit (Pbsrl(res, ah)); + emit (Pxorl_ri(res, coqint_of_camlint 31l)); emit (Pjmp_l lbl2); emit (Plabel lbl1); - emit (Pbsr(res, al)); - emit (Pxor_ri(res, coqint_of_camlint 63l)); + 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 (Pbsf (res,a1)) + 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 (Ptest_rr(al, al)); + emit (Ptestl_rr(al, al)); emit (Pjcc(Cond_e, lbl1)); - emit (Pbsf(res, al)); + emit (Pbsfl(res, al)); emit (Pjmp_l lbl2); emit (Plabel lbl1); - emit (Pbsf(res, ah)); - emit (Padd_ri(res, coqint_of_camlint 32l)); + 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) -> @@ -320,75 +405,120 @@ let expand_builtin_inline name args res = (* 64-bit integer arithmetic *) | "__builtin_negl", [BA_splitlong(BA(IR ah), BA(IR al))], BR_splitlong(BR(IR rh), BR(IR rl)) -> - assert (ah = EDX && al = EAX && rh = EDX && rl = EAX); - emit (Pneg EAX); - emit (Padc_ri (EDX,_0)); - emit (Pneg EDX) + 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 = EDX && al = EAX && bh = ECX && bl = EBX && rh = EDX && rl = EAX); - emit (Padd_rr (EAX,EBX)); - emit (Padc_rr (EDX,ECX)) + 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 = EDX && al = EAX && bh = ECX && bl = EBX && rh = EDX && rl = EAX); - emit (Psub_rr (EAX,EBX)); - emit (Psbb_rr (EDX,ECX)) + 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 = EAX && b = EDX && rh = EDX && rl = EAX); - emit (Pmul_r EDX) + 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 (Pmov_rm (res, linear_addr a1 _0)); - emit (Pbswap 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 = ECX then EDX else ECX in + 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 _0, tmp)) + emit (Pmovw_mr (linear_addr a1 _0z, tmp)) | "__builtin_write32_reversed", [BA(IR a1); BA(IR a2)], _ -> - let tmp = if a1 = ECX then EDX else ECX in + let tmp = if a1 = RCX then RDX else RCX in if a2 <> tmp then emit (Pmov_rr (tmp,a2)); - emit (Pbswap tmp); - emit (Pmov_mr (linear_addr a1 _0, tmp)) + emit (Pbswap32 tmp); + emit (Pmovl_mr (linear_addr a1 _0z, tmp)) (* Vararg stuff *) | "__builtin_va_start", [BA(IR a)], _ -> - expand_builtin_va_start 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 (Pxchg_rr (EAX,EAX)) + 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) -> - let sz = sp_adjustment sz in - let addr = linear_addr ESP (coqint_of_camlint (Int32.add sz 4l)) in - let addr' = linear_addr ESP ofs_link in - let sz' = coqint_of_camlint sz in - emit (Psub_ri (ESP,sz')); - emit (Pcfi_adjust sz'); - emit (Plea (EDX,addr)); - emit (Pmov_mr (addr',EDX)); - PrintAsmaux.current_function_stacksize := sz + 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) -> - let sz = sp_adjustment sz in - emit (Padd_ri (ESP,coqint_of_camlint sz)) + 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 @@ -399,10 +529,7 @@ let expand_instruction instr = | EF_vstore chunk -> expand_builtin_vstore chunk args | EF_memcpy(sz, al) -> - expand_builtin_memcpy - (Int32.to_int (camlint_of_coqint sz)) - (Int32.to_int (camlint_of_coqint al)) - args + 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 _ -> @@ -413,14 +540,15 @@ let expand_instruction instr = | _ -> emit instr let int_reg_to_dwarf = function - | EAX -> 0 - | EBX -> 3 - | ECX -> 1 - | EDX -> 2 - | ESI -> 6 - | EDI -> 7 - | EBP -> 5 - | ESP -> 4 + | RAX -> 0 + | RBX -> 3 + | RCX -> 1 + | RDX -> 2 + | RSI -> 6 + | RDI -> 7 + | RBP -> 5 + | RSP -> 4 + | _ -> assert false (* TODO *) let float_reg_to_dwarf = function | XMM0 -> 21 @@ -431,6 +559,7 @@ let float_reg_to_dwarf = function | XMM5 -> 26 | XMM6 -> 27 | XMM7 -> 28 + | _ -> assert false (* TODO *) let preg_to_dwarf = function | IR r -> int_reg_to_dwarf r diff --git a/ia32/Asmgen.v b/ia32/Asmgen.v index 1d718c26..4662f964 100644 --- a/ia32/Asmgen.v +++ b/ia32/Asmgen.v @@ -2,7 +2,7 @@ (* *) (* The Compcert verified compiler *) (* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Xavier Leroy, INRIA Paris *) (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) @@ -10,10 +10,10 @@ (* *) (* *********************************************************************) -(** Translation from Mach to IA32 Asm. *) +(** Translation from Mach to IA32 assembly language *) Require Import Coqlib Errors. -Require Import Integers Floats AST Memdata. +Require Import AST Integers Floats Memdata. Require Import Op Locations Mach Asm. Open Local Scope string_scope. @@ -37,7 +37,7 @@ Definition ireg_of (r: mreg) : res ireg := 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 various operations. *) +(** Smart constructors for some operations. *) Definition mk_mov (rd rs: preg) (k: code) : res code := match rd, rs with @@ -48,22 +48,19 @@ Definition mk_mov (rd rs: preg) (k: code) : res code := Definition mk_shrximm (n: int) (k: code) : res code := let p := Int.sub (Int.shl Int.one n) Int.one in - OK (Ptest_rr EAX EAX :: - Plea ECX (Addrmode (Some EAX) None (inl _ p)) :: - Pcmov Cond_l EAX ECX :: - Psar_ri EAX n :: k). + 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 low_ireg (r: ireg) : bool := - match r with - | EAX | EBX | ECX | EDX => true - | ESI | EDI | EBP | ESP => false - end. + match r with RAX | RBX | RCX | RDX => true | _ => false end. Definition mk_intconv (mk: ireg -> ireg -> instruction) (rd rs: ireg) (k: code) := - if low_ireg rs then + if Archi.ptr64 || low_ireg rs then OK (mk rd rs :: k) else - OK (Pmov_rr EAX rs :: mk rd EAX :: k). + OK (Pmov_rr RAX rs :: mk rd RAX :: k). Definition addressing_mentions (addr: addrmode) (r: ireg) : bool := match addr with Addrmode base displ const => @@ -71,39 +68,44 @@ Definition addressing_mentions (addr: addrmode) (r: ireg) : bool := || match displ with Some(r', sc) => ireg_eq r r' | None => false end end. -Definition mk_smallstore (sto: addrmode -> ireg ->instruction) - (addr: addrmode) (rs: ireg) (k: code) := - if low_ireg rs then - OK (sto addr rs :: k) - else if addressing_mentions addr EAX then - OK (Plea ECX addr :: Pmov_rr EAX rs :: - sto (Addrmode (Some ECX) None (inl _ Int.zero)) EAX :: k) +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 EAX rs :: sto addr EAX :: k). + OK (Pmov_rr RAX rs :: Pmovb_mr addr RAX :: k). (** Accessing slots in the stack frame. *) -Definition loadind (base: ireg) (ofs: int) (ty: typ) (dst: mreg) (k: code) := +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 (Pmov_rm r (Addrmode (Some base) None (inl _ ofs)) :: k) - | Tsingle, FR r => OK (Pmovss_fm r (Addrmode (Some base) None (inl _ ofs)) :: k) - | Tsingle, ST0 => OK (Pflds_m (Addrmode (Some base) None (inl _ ofs)) :: k) - | Tfloat, FR r => OK (Pmovsd_fm r (Addrmode (Some base) None (inl _ ofs)) :: k) - | Tfloat, ST0 => OK (Pfldl_m (Addrmode (Some base) None (inl _ ofs)) :: k) - | Tany32, IR r => OK (Pmov_rm_a r (Addrmode (Some base) None (inl _ ofs)) :: k) - | Tany64, FR r => OK (Pmovsd_fm_a r (Addrmode (Some base) None (inl _ ofs)) :: k) + | 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: int) (ty: typ) (k: code) := +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 (Pmov_mr (Addrmode (Some base) None (inl _ ofs)) r :: k) - | Tsingle, FR r => OK (Pmovss_mf (Addrmode (Some base) None (inl _ ofs)) r :: k) - | Tsingle, ST0 => OK (Pfstps_m (Addrmode (Some base) None (inl _ ofs)) :: k) - | Tfloat, FR r => OK (Pmovsd_mf (Addrmode (Some base) None (inl _ ofs)) r :: k) - | Tfloat, ST0 => OK (Pfstpl_m (Addrmode (Some base) None (inl _ ofs)) :: k) - | Tany32, IR r => OK (Pmov_mr_a (Addrmode (Some base) None (inl _ ofs)) r :: k) - | Tany64, FR r => OK (Pmovsd_mf_a (Addrmode (Some base) None (inl _ ofs)) r :: k) + | 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. @@ -115,7 +117,7 @@ Definition transl_addressing (a: addressing) (args: list mreg): res addrmode := 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, Int.one)) (inl _ n)) + 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 => @@ -128,11 +130,30 @@ Definition transl_addressing (a: addressing) (args: list mreg): res addrmode := | 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 ESP) None (inl _ n)) + 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. *) @@ -156,14 +177,23 @@ 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 (Pcmp_rr r1 r2 :: k) + 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 (Pcmp_rr r1 r2 :: k) + 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 Ptest_rr r1 r1 :: k else Pcmp_ri r1 n :: k) + 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 (Pcmp_ri r1 n :: k) + 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 => @@ -173,9 +203,9 @@ Definition transl_cond | 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 (Ptest_ri r1 n :: k) + do r1 <- ireg_of a1; OK (Ptestl_ri r1 n :: k) | Cmasknotzero n, a1 :: nil => - do r1 <- ireg_of a1; OK (Ptest_ri r1 n :: k) + do r1 <- ireg_of a1; OK (Ptestl_ri r1 n :: k) | _, _ => Error(msg "Asmgen.transl_cond") end. @@ -213,6 +243,10 @@ Definition testcond_for_condition (cond: condition) : extcond := | 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 @@ -242,19 +276,19 @@ Definition mk_setcc_base (cond: extcond) (rd: ireg) (k: code) := | Cond_base c => Psetcc c rd :: k | Cond_and c1 c2 => - if ireg_eq rd EAX - then Psetcc c1 EAX :: Psetcc c2 ECX :: Pand_rr EAX ECX :: k - else Psetcc c1 EAX :: Psetcc c2 rd :: Pand_rr rd EAX :: k + 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 EAX - then Psetcc c1 EAX :: Psetcc c2 ECX :: Por_rr EAX ECX :: k - else Psetcc c1 EAX :: Psetcc c2 rd :: Por_rr rd EAX :: k + 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 low_ireg rd + if Archi.ptr64 || low_ireg rd then mk_setcc_base cond rd k - else mk_setcc_base cond EAX (Pmov_rr rd EAX :: k). + else mk_setcc_base cond RAX (Pmov_rr rd RAX :: k). Definition mk_jcc (cond: extcond) (lbl: label) (k: code) := match cond with @@ -273,7 +307,10 @@ Definition transl_op 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 Pxor_r r else Pmov_ri r n) :: k) + 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) @@ -282,110 +319,205 @@ Definition transl_op 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_ra r id :: k) + 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; mk_intconv Pmovsw_rr r r1 k + 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; mk_intconv Pmovzw_rr r r1 k + 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 (Pneg r :: k) + 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 (Psub_rr r r2 :: k) + 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 (Pimul_rr r r2 :: k) + 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 (Pimul_ri r n :: k) + 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 (Pimul_r r2 :: k) + 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 (Pmul_r r2 :: k) + 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 :: Pidiv ECX :: k) + 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(Pxor_r EDX :: Pdiv ECX :: k) + 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 :: Pidiv ECX :: k) + 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(Pxor_r EDX :: Pdiv ECX :: k) + 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 (Pand_rr r r2 :: k) + 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 (Pand_ri r n :: k) + 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 (Por_rr r r2 :: k) + 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 (Por_ri r n :: k) + 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 (Pxor_rr r r2 :: k) + 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 (Pxor_ri r n :: k) + 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 (Pnot r :: k) + 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 (Psal_rcl r :: k) + 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 (Psal_ri r n :: k) + 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 (Psar_rcl r :: k) + 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 (Psar_ri r n :: k) + 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 (Pshr_rcl r :: k) + 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 (Pshr_ri r n :: k) + 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 (Pror_ri r n :: k) + 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 (Plea r am :: k) + 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) + | 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) + | 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) @@ -434,6 +566,14 @@ Definition transl_op 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) @@ -457,7 +597,9 @@ Definition transl_load (chunk: memory_chunk) | Mint16signed => do r <- ireg_of dest; OK(Pmovsw_rm r am :: k) | Mint32 => - do r <- ireg_of dest; OK(Pmov_rm r am :: k) + 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 => @@ -472,11 +614,13 @@ Definition transl_store (chunk: memory_chunk) do am <- transl_addressing addr args; match chunk with | Mint8unsigned | Mint8signed => - do r <- ireg_of src; mk_smallstore Pmovb_mr am r k + 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(Pmov_mr am r :: k) + 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 => @@ -488,18 +632,18 @@ Definition transl_store (chunk: memory_chunk) (** Translation of a Mach instruction. *) Definition transl_instr (f: Mach.function) (i: Mach.instruction) - (edx_is_parent: bool) (k: code) := + (ax_is_parent: bool) (k: code) := match i with | Mgetstack ofs ty dst => - loadind ESP ofs ty dst k + loadind RSP ofs ty dst k | Msetstack src ofs ty => - storeind src ESP ofs ty k + storeind src RSP ofs ty k | Mgetparam ofs ty dst => - if edx_is_parent then - loadind EDX ofs ty dst k + if ax_is_parent then + loadind RAX ofs ty dst k else - (do k1 <- loadind EDX ofs ty dst k; - loadind ESP f.(fn_link_ofs) Tint DX k1) + (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 => @@ -537,35 +681,35 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) 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 DX) + | 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) (it1p: bool) := +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 it1p i1); - transl_instr f i1 it1p k + 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) - (it1p: bool) (k: code -> res code) := + (axp: bool) (k: code -> res code) := match il with | nil => k nil | i1 :: il' => - transl_code_rec f il' (it1_is_parent it1p i1) - (fun c1 => do c2 <- transl_instr f i1 it1p c1; k c2) + 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) (it1p: bool) := - transl_code_rec f il it1p (fun c => OK c). +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, @@ -579,7 +723,7 @@ Definition transl_function (f: Mach.function) := Definition transf_function (f: Mach.function) : res Asm.function := do tf <- transl_function f; - if zlt Int.max_unsigned (list_length_z tf.(fn_code)) + if zlt Ptrofs.max_unsigned (list_length_z tf.(fn_code)) then Error (msg "code size exceeded") else OK tf. diff --git a/ia32/Asmgenproof.v b/ia32/Asmgenproof.v index c498b601..bf14f010 100644 --- a/ia32/Asmgenproof.v +++ b/ia32/Asmgenproof.v @@ -2,7 +2,7 @@ (* *) (* The Compcert verified compiler *) (* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Xavier Leroy, INRIA Paris *) (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) @@ -10,7 +10,7 @@ (* *) (* *********************************************************************) -(** Correctness proof for x86 generation: main proof. *) +(** Correctness proof for x86-64 generation: main proof. *) Require Import Coqlib Errors. Require Import Integers Floats AST Linking. @@ -64,9 +64,9 @@ Qed. Lemma transf_function_no_overflow: forall f tf, - transf_function f = OK tf -> list_length_z (fn_code tf) <= Int.max_unsigned. + transf_function f = OK tf -> list_length_z (fn_code tf) <= Ptrofs.max_unsigned. Proof. - intros. monadInv H. destruct (zlt Int.max_unsigned (list_length_z (fn_code x))); monadInv EQ0. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z (fn_code x))); monadInv EQ0. omega. Qed. @@ -141,14 +141,12 @@ Proof. Qed. Hint Resolve mk_intconv_label: labels. -Remark mk_smallstore_label: - forall f addr r k c, mk_smallstore f addr r k = OK c -> - (forall r addr, nolabel (f r addr)) -> - tail_nolabel k c. +Remark mk_storebyte_label: + forall addr r k c, mk_storebyte addr r k = OK c -> tail_nolabel k c. Proof. - unfold mk_smallstore; intros. TailNoLabel. + unfold mk_storebyte; intros. TailNoLabel. Qed. -Hint Resolve mk_smallstore_label: labels. +Hint Resolve mk_storebyte_label: labels. Remark loadind_label: forall base ofs ty dst k c, @@ -170,14 +168,14 @@ 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 EAX); TailNoLabel. + 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 (low_ireg rd). + 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. @@ -196,7 +194,8 @@ Remark transl_cond_label: Proof. unfold transl_cond; intros. destruct cond; TailNoLabel. - destruct (Int.eq_dec i Int.zero); 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. @@ -209,9 +208,11 @@ Remark transl_op_label: tail_nolabel k c. Proof. unfold transl_op; intros. destruct op; TailNoLabel. - destruct (Int.eq_dec i Int.zero); TailNoLabel. - destruct (Float.eq_dec f Float.zero); TailNoLabel. - destruct (Float32.eq_dec f Float32.zero); 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. @@ -285,7 +286,7 @@ Lemma transl_find_label: | 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 Int.max_unsigned (list_length_z (fn_code x))); inv EQ0. + 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. @@ -309,10 +310,10 @@ Proof. 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 (Int.repr pos'))). + 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 Int.unsigned_repr. replace (pos' - 0) with pos' in Q. + 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. @@ -328,7 +329,7 @@ Proof. - intros. exploit transl_instr_label; eauto. destruct i; try (intros [A B]; apply A). intros. subst c0. repeat constructor. - intros. monadInv H0. - destruct (zlt Int.max_unsigned (list_length_z (fn_code x))); inv EQ0. + 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. @@ -360,7 +361,7 @@ Inductive match_states: Mach.state -> Asm.state -> Prop := (MEXT: Mem.extends m m') (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc) (AG: agree ms sp rs) - (DXP: ep = true -> rs#EDX = parent_sp s), + (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: @@ -368,7 +369,7 @@ Inductive match_states: Mach.state -> Asm.state -> Prop := (STACKS: match_stack ge s) (MEXT: Mem.extends m m') (AG: agree ms (parent_sp s) rs) - (ATPC: rs PC = Vptr fb Int.zero) + (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') @@ -391,7 +392,7 @@ Lemma exec_straight_steps: exists rs2, exec_straight tge tf c rs1 m1' k rs2 m2' /\ agree ms2 sp rs2 - /\ (it1_is_parent ep i = true -> rs2#EDX = parent_sp s)) -> + /\ (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'. @@ -503,19 +504,19 @@ Local Transparent destroyed_by_setstack. intros [v' [C D]]. Opaque loadind. left; eapply exec_straight_steps; eauto; intros. - assert (DIFF: negb (mreg_eq dst DX) = true -> IR EDX <> preg_of dst). - intros. change (IR EDX) with (preg_of DX). red; intros. - unfold proj_sumbool in H1. destruct (mreg_eq dst DX); try discriminate. + 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. -(* EDX contains parent *) +(* RAX contains parent *) exploit loadind_correct. eexact TR. - instantiate (2 := rs0). rewrite DXP; eauto. + 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. -(* EDX does not contain parent *) +(* 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. @@ -565,17 +566,17 @@ Opaque loadind. - (* Mcall *) assert (f0 = f) by congruence. subst f0. inv AT. - assert (NOOV: list_length_z tf.(fn_code) <= Int.max_unsigned). + 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' Int.zero). + assert (rs rf = Vptr f' Ptrofs.zero). destruct (rs rf); try discriminate. - revert H; predSpec Int.eq Int.eq_spec i Int.zero; intros; congruence. - assert (rs0 x0 = Vptr f' Int.zero). + 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 (Int.add ofs Int.one)) fb f c false tf x). + 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. @@ -589,7 +590,7 @@ Opaque loadind. Simplifs. rewrite <- H2. auto. + (* Direct call *) generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1. - assert (TCA: transl_code_at_pc ge (Vptr fb (Int.add ofs Int.one)) fb f c false tf x). + 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. @@ -605,7 +606,7 @@ Opaque loadind. - (* Mtailcall *) assert (f0 = f) by congruence. subst f0. inv AT. - assert (NOOV: list_length_z tf.(fn_code) <= Int.max_unsigned). + 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]]. @@ -615,18 +616,19 @@ Opaque loadind. 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' Int.zero). + assert (rs rf = Vptr f' Ptrofs.zero). destruct (rs rf); try discriminate. - revert H; predSpec Int.eq Int.eq_spec i Int.zero; intros; congruence. - assert (rs0 x0 = Vptr f' Int.zero). + 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. rewrite C. rewrite A. rewrite <- (sp_val _ _ _ AG). rewrite E. 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.add rs0#PC Vone). auto. rewrite <- H4. simpl. eauto. + 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. @@ -639,9 +641,10 @@ Opaque loadind. 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. + 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.add rs0#PC Vone). auto. rewrite <- H4. simpl. eauto. + 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. @@ -784,9 +787,10 @@ Transparent destroyed_by_jumptable. - (* Mreturn *) assert (f0 = f) by congruence. subst f0. inv AT. - assert (NOOV: list_length_z tf.(fn_code) <= Int.max_unsigned). + 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]]. @@ -799,7 +803,7 @@ Transparent destroyed_by_jumptable. 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.add rs0#PC Vone). auto. rewrite <- H3. simpl. eauto. + 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. @@ -809,7 +813,7 @@ Transparent destroyed_by_jumptable. - (* internal function *) exploit functions_translated; eauto. intros [tf [A B]]. monadInv B. generalize EQ; intros EQ'. monadInv EQ'. - destruct (zlt Int.max_unsigned (list_length_z (fn_code x0))); inv EQ1. + 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. @@ -820,9 +824,11 @@ Transparent destroyed_by_jumptable. intros [m3' [P Q]]. left; econstructor; split. apply plus_one. econstructor; eauto. - simpl. rewrite Int.unsigned_zero. simpl. eauto. - simpl. rewrite C. simpl in F. rewrite (sp_val _ _ _ AG) in F. rewrite F. - simpl in P. rewrite ATLR. rewrite P. 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. @@ -863,12 +869,14 @@ Proof. econstructor; split. econstructor. eapply (Genv.init_mem_transf_partial TRANSF); eauto. - replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Int.zero) - with (Vptr fb Int.zero). + replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero) + with (Vptr fb Ptrofs.zero). econstructor; eauto. constructor. apply Mem.extends_refl. - split. auto. simpl. unfold Vzero; congruence. intros. rewrite Regmap.gi. auto. + 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. @@ -880,7 +888,9 @@ Lemma transf_final_states: match_states st1 st2 -> Mach.final_state st1 r -> Asm.final_state st2 r. Proof. intros. inv H0. inv H. constructor. auto. - compute in H1. inv H1. + 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. diff --git a/ia32/Asmgenproof1.v b/ia32/Asmgenproof1.v index 9703d419..fa75e7e7 100644 --- a/ia32/Asmgenproof1.v +++ b/ia32/Asmgenproof1.v @@ -2,7 +2,7 @@ (* *) (* The Compcert verified compiler *) (* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Xavier Leroy, INRIA Paris *) (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) @@ -10,27 +10,17 @@ (* *) (* *********************************************************************) -(** Correctness proof for IA32 generation: auxiliary results. *) +(** Correctness proof for x86-64 generation: auxiliary results. *) Require Import Coqlib. -Require Import AST. -Require Import Errors. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Op. -Require Import Locations. -Require Import Mach. -Require Import Asm. -Require Import Asmgen. -Require Import Asmgenproof0. -Require Import Conventions. +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 IA32 registers *) +(** * Correspondence between Mach registers and x86 registers *) Lemma agree_nextinstr_nf: forall ms sp rs, @@ -63,7 +53,7 @@ Qed. Lemma nextinstr_nf_set_preg: forall rs m v, - (nextinstr_nf (rs#(preg_of m) <- v))#PC = Val.add rs#PC Vone. + (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. @@ -92,7 +82,7 @@ Ltac Simplif := Ltac Simplifs := repeat Simplif. -(** * Correctness of IA32 constructor functions *) +(** * Correctness of x86-64 constructor functions *) Section CONSTRUCTORS. @@ -114,7 +104,7 @@ Proof. (* mov *) econstructor. split. apply exec_straight_one. simpl. eauto. auto. split. Simplifs. intros; Simplifs. -(* movd *) +(* movsd *) econstructor. split. apply exec_straight_one. simpl. eauto. auto. split. Simplifs. intros; Simplifs. Qed. @@ -161,16 +151,56 @@ Proof. 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#EAX) (Vint n) = Some v -> + Val.shrx (rs1#RAX) (Vint n) = Some v -> exists rs2, exec_straight ge fn c rs1 m k rs2 m - /\ rs2#EAX = v - /\ forall r, data_preg r = true -> r <> EAX -> r <> ECX -> rs2#r = rs1#r. + /\ 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]]]]. @@ -178,16 +208,16 @@ Proof. 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#ECX <- (Vint x'))). - set (rs4 := nextinstr (if Int.lt x Int.zero then rs3#EAX <- (Vint x') else rs3)). - set (rs5 := nextinstr_nf (rs4#EAX <- (Val.shr rs4#EAX (Vint n)))). - assert (rs3#EAX = Vint x). unfold rs3. Simplifs. - assert (rs3#ECX = Vint x'). unfold rs3. Simplifs. + 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 EAX) with (rs1 EAX). rewrite A. simpl. - rewrite (Int.add_commut Int.zero tnm1). rewrite Int.add_zero. auto. auto. + 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. @@ -210,9 +240,9 @@ Lemma mk_intconv_correct: 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 <> EAX -> rs2#r = rs1#r. + /\ forall r, data_preg r = true -> r <> rd -> r <> RAX -> rs2#r = rs1#r. Proof. - unfold mk_intconv; intros. destruct (low_ireg rs); monadInv H. + 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. @@ -226,149 +256,213 @@ 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_addrmode ge a rs1 = eval_addrmode ge a rs2. + eval_addrmode32 ge a rs1 = eval_addrmode32 ge a rs2. Proof. - intros until rs2; intro AG. unfold addressing_mentions, eval_addrmode. + 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_smallstore_correct: - forall chunk sto addr r k c rs1 m1 m2, - mk_smallstore sto addr r k = OK c -> - Mem.storev chunk m1 (eval_addrmode ge addr rs1) (rs1 r) = Some m2 -> - (forall c r addr rs m, - exec_instr ge c (sto addr r) rs m = exec_store ge chunk m addr rs r nil) -> +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 -> r <> EAX /\ r <> ECX -> rs2#r = rs1#r. + /\ 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_smallstore; intros. - remember (low_ireg r) as low. destruct low. + unfold mk_storebyte; intros. + destruct (Archi.ptr64 || low_ireg r) eqn:E. (* low reg *) - monadInv H. econstructor; split. apply exec_straight_one. rewrite H1. - unfold exec_store. rewrite H0. eauto. auto. + monadInv H. econstructor; split. apply exec_straight_one. + simpl. unfold exec_store. rewrite H0. eauto. auto. intros; Simplifs. (* high reg *) - remember (addressing_mentions addr EAX) as mentions. destruct mentions; monadInv H. -(* EAX is mentioned. *) - assert (r <> ECX). red; intros; subst r; discriminate. - set (rs2 := nextinstr (rs1#ECX <- (eval_addrmode ge addr rs1))). - set (rs3 := nextinstr (rs2#EAX <- (rs1 r))). + 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. - rewrite H1. unfold exec_store. simpl. rewrite Int.add_zero. - change (rs3 EAX) with (rs1 r). - change (rs3 ECX) with (eval_addrmode ge addr rs1). - replace (Val.add (eval_addrmode ge addr rs1) (Vint Int.zero)) + 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. - destruct (eval_addrmode ge addr rs1); simpl in H0; try discriminate. - simpl. rewrite Int.add_zero; auto. + 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 H3. Simplifs. unfold rs3; Simplifs. unfold rs2; Simplifs. -(* EAX is not mentioned *) - set (rs2 := nextinstr (rs1#EAX <- (rs1 r))). + 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. - rewrite H1. unfold exec_store. - rewrite (addressing_mentions_correct addr EAX rs2 rs1); auto. - change (rs2 EAX) with (rs1 r). rewrite H0. eauto. + 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 H2. simpl. Simplifs. unfold rs2; Simplifs. + 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. +- do 2 f_equal. rewrite Int64.add_zero_l. rewrite <- (Ptrofs.repr_unsigned ofs) at 2. auto with ptrofs. +- do 2 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.add rs#base (Vint ofs)) = Some v -> + 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 * int) ofs)) in *. - assert (eval_addrmode ge addr rs = Val.add rs#base (Vint ofs)). - unfold addr. simpl. rewrite Int.add_commut; rewrite Int.add_zero; auto. + 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. -- destruct ty; try discriminate; destruct (preg_of dst); inv H; simpl in H0; - apply exec_straight_one; auto; simpl; unfold exec_load; rewrite H1, H0; auto. +- 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.add rs#base (Vint ofs)) (rs#(preg_of src)) = Some m' -> + 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. -Local Transparent destroyed_by_setstack. unfold storeind; intros. - set (addr := Addrmode (Some base) None (inl (ident * int) ofs)) in *. - assert (eval_addrmode ge addr rs = Val.add rs#base (Vint ofs)). - unfold addr. simpl. rewrite Int.add_commut; rewrite Int.add_zero; auto. - destruct ty; try discriminate; destruct (preg_of src); inv H; simpl in H0; + 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 H1, H0; eauto|auto] + [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_correct: +Lemma transl_addressing_mode_32_correct: forall addr args am (rs: regset) v, transl_addressing addr args = OK am -> - eval_addressing ge (rs ESP) addr (List.map rs (List.map preg_of args)) = Some v -> - Val.lessdef v (eval_addrmode ge am rs). + 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 n, Int.add Int.zero n = n). - intros. rewrite Int.add_commut. apply Int.add_zero. - assert (B: forall n i, (if Int.eq i Int.one then Vint n else Vint (Int.mul n i)) = Vint (Int.mul n i)). - intros. predSpec Int.eq Int.eq_spec i Int.one. - subst i. rewrite Int.mul_one. auto. auto. + 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.mul v (Vint i)) - (if Int.eq i Int.one then v else Val.mul v (Vint i))). - intros. predSpec Int.eq Int.eq_spec i Int.one. - subst i. destruct v; simpl; auto. rewrite Int.mul_one; auto. - destruct v; simpl; auto. + 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. -(* indexed *) - monadInv H. rewrite (ireg_of_eq _ _ EQ). simpl. rewrite A; auto. -(* indexed2 *) - monadInv H. rewrite (ireg_of_eq _ _ EQ); rewrite (ireg_of_eq _ _ EQ1). simpl. - rewrite Val.add_assoc; auto. -(* scaled *) - monadInv H. rewrite (ireg_of_eq _ _ EQ). unfold eval_addrmode. - rewrite Val.add_permut. simpl. rewrite A. apply Val.add_lessdef; auto. -(* indexed2scaled *) - monadInv H. rewrite (ireg_of_eq _ _ EQ); rewrite (ireg_of_eq _ _ EQ1); simpl. - apply Val.add_lessdef; auto. apply Val.add_lessdef; auto. -(* global *) - inv H. simpl. unfold Genv.symbol_address. - destruct (Genv.find_symbol ge i); simpl; auto. repeat rewrite Int.add_zero. auto. -(* based *) - monadInv H. rewrite (ireg_of_eq _ _ EQ). simpl. - unfold Genv.symbol_address. destruct (Genv.find_symbol ge i); simpl; auto. - rewrite Int.add_zero. rewrite Val.add_commut. auto. -(* basedscaled *) - monadInv H. rewrite (ireg_of_eq _ _ EQ). unfold eval_addrmode. - rewrite (Val.add_commut Vzero). rewrite Val.add_assoc. rewrite Val.add_permut. - apply Val.add_lessdef; auto. destruct (rs x); simpl; auto. rewrite B. simpl. - rewrite Int.add_zero. auto. -(* instack *) - inv H; simpl. rewrite A; auto. + 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. do 2 f_equal. simpl. rewrite Int64.add_zero_l; auto. Qed. (** Processor conditions and comparisons *) @@ -390,53 +484,7 @@ Proof. intros. Simplifs. Qed. -Lemma int_signed_eq: - forall x y, Int.eq x y = zeq (Int.signed x) (Int.signed y). -Proof. - intros. unfold Int.eq. unfold proj_sumbool. - destruct (zeq (Int.unsigned x) (Int.unsigned y)); - destruct (zeq (Int.signed x) (Int.signed y)); auto. - elim n. unfold Int.signed. rewrite e; auto. - elim n. apply Int.eqm_small_eq; auto with ints. - eapply Int.eqm_trans. apply Int.eqm_sym. apply Int.eqm_signed_unsigned. - rewrite e. apply Int.eqm_signed_unsigned. -Qed. - -Lemma int_not_lt: - forall x y, negb (Int.lt y x) = (Int.lt x y || Int.eq x y). -Proof. - intros. unfold Int.lt. rewrite int_signed_eq. unfold proj_sumbool. - destruct (zlt (Int.signed y) (Int.signed x)). - rewrite zlt_false. rewrite zeq_false. auto. omega. omega. - destruct (zeq (Int.signed x) (Int.signed y)). - rewrite zlt_false. auto. omega. - rewrite zlt_true. auto. omega. -Qed. - -Lemma int_lt_not: - forall x y, Int.lt y x = negb (Int.lt x y) && negb (Int.eq x y). -Proof. - intros. rewrite <- negb_orb. rewrite <- int_not_lt. rewrite negb_involutive. auto. -Qed. - -Lemma int_not_ltu: - forall x y, negb (Int.ltu y x) = (Int.ltu x y || Int.eq x y). -Proof. - intros. unfold Int.ltu, Int.eq. - destruct (zlt (Int.unsigned y) (Int.unsigned x)). - rewrite zlt_false. rewrite zeq_false. auto. omega. omega. - destruct (zeq (Int.unsigned x) (Int.unsigned y)). - rewrite zlt_false. auto. omega. - rewrite zlt_true. auto. omega. -Qed. - -Lemma int_ltu_not: - forall x y, Int.ltu y x = negb (Int.ltu x y) && negb (Int.eq x y). -Proof. - intros. rewrite <- negb_orb. rewrite <- int_not_ltu. rewrite negb_involutive. auto. -Qed. - -Lemma testcond_for_signed_comparison_correct: +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) @@ -453,12 +501,12 @@ Proof. 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. + 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_correct: +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) @@ -469,42 +517,143 @@ Proof. 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 *) +- (* 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. + 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 *) +- (* int ptr *) + unfold Val.cmpu_bool; destruct Archi.ptr64; try discriminate. destruct (Int.eq i Int.zero && - (Mem.valid_pointer m b0 (Int.unsigned i0) || Mem.valid_pointer m b0 (Int.unsigned i0 - 1))) eqn:?; try discriminate. - destruct c; simpl in *; inv H1. - rewrite Heqb1; reflexivity. - rewrite Heqb1; reflexivity. -(* ptr int *) + (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 (Int.unsigned i) || Mem.valid_pointer m b0 (Int.unsigned i - 1))) eqn:?; try discriminate. - destruct c; simpl in *; inv H1. - rewrite Heqb1; reflexivity. - rewrite Heqb1; reflexivity. -(* ptr ptr *) - simpl. - fold (Mem.weak_valid_pointer m b0 (Int.unsigned i)) in *. - fold (Mem.weak_valid_pointer m b1 (Int.unsigned i0)) in *. + (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 (Int.unsigned i) && - Mem.weak_valid_pointer m b1 (Int.unsigned i0)); inversion H1. + 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 (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. - destruct (Mem.valid_pointer m b0 (Int.unsigned i) && - Mem.valid_pointer m b1 (Int.unsigned i0)); try discriminate. + 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. @@ -793,35 +942,63 @@ Lemma transl_cond_correct: Proof. unfold transl_cond; intros. destruct cond; repeat (destruct args; try discriminate); monadInv H. -(* comp *) +- (* 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_correct; eauto. + eapply testcond_for_signed_comparison_32_correct; eauto. intros. unfold compare_ints. Simplifs. -(* compu *) +- (* 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_correct; eauto. + eapply testcond_for_unsigned_comparison_32_correct; eauto. intros. unfold compare_ints. Simplifs. -(* compimm *) - simpl. rewrite (ireg_of_eq _ _ EQ). destruct (Int.eq_dec i Int.zero). +- (* 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_correct; eauto. + 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 i)) eqn:?; auto. - eapply testcond_for_signed_comparison_correct; eauto. + 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 *) +- (* 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 i)) eqn:?; auto. - eapply testcond_for_unsigned_comparison_correct; eauto. + 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. -(* compf *) +- (* 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. @@ -830,7 +1007,7 @@ Proof. 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 *) +- (* 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. @@ -839,7 +1016,7 @@ Proof. 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 *) +- (* 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. @@ -848,7 +1025,7 @@ Proof. 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 *) +- (* 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. @@ -857,19 +1034,19 @@ Proof. 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 *) +- (* 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 i0 i)) Vzero m). - intros [A B]. rewrite A. unfold Val.cmpu; simpl. destruct (Int.eq (Int.and i0 i) Int.zero); 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 *) +- (* 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 i0 i)) Vzero m). - intros [A B]. rewrite A. unfold Val.cmpu; simpl. destruct (Int.eq (Int.and i0 i) Int.zero); 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. @@ -890,7 +1067,7 @@ Lemma mk_setcc_base_correct: 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 <> EAX /\ r <> ECX -> r <> rd -> rs2#r = rs1#r. + /\ forall r, data_preg r = true -> r <> RAX /\ r <> RCX -> r <> rd -> rs2#r = rs1#r. Proof. intros. destruct cond; simpl in *. - (* base *) @@ -913,7 +1090,7 @@ Proof. destruct b; auto. auto. rewrite H; clear H. - destruct (ireg_eq rd EAX). + destruct (ireg_eq rd RAX). subst rd. econstructor; split. eapply exec_straight_three. simpl; eauto. @@ -947,7 +1124,7 @@ Proof. auto. } rewrite H; clear H. - destruct (ireg_eq rd EAX). + destruct (ireg_eq rd RAX). subst rd. econstructor; split. eapply exec_straight_three. simpl; eauto. @@ -970,9 +1147,9 @@ Lemma mk_setcc_correct: 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 <> EAX /\ r <> ECX -> r <> rd -> rs2#r = rs1#r. + /\ forall r, data_preg r = true -> r <> RAX /\ r <> RCX -> r <> rd -> rs2#r = rs1#r. Proof. - intros. unfold mk_setcc. destruct (low_ireg rd). + 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. @@ -1002,7 +1179,7 @@ Ltac TranslOp := 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#ESP) op (map rs (map preg_of args)) m = Some v -> + 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) @@ -1028,76 +1205,131 @@ Transparent destroyed_by_op. exploit mk_mov_correct; eauto. intros [rs2 [A [B C]]]. apply SAME. exists rs2. eauto. (* intconst *) - apply SAME. destruct (Int.eq_dec i Int.zero). subst i. TranslOp. TranslOp. + 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 f Float.zero). subst f. TranslOp. TranslOp. + apply SAME. destruct (Float.eq_dec n Float.zero). subst n. TranslOp. TranslOp. (* singleconst *) - apply SAME. destruct (Float32.eq_dec f Float32.zero). subst f. TranslOp. TranslOp. + 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. -(* cast16signed *) - apply SAME. eapply mk_intconv_correct; eauto. -(* cast16unsigned *) - 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 EAX) (rs ECX)). left; congruence. + 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#EDX <- (Vint nh))). + set (rs1 := nextinstr_nf (rs#RDX <- (Vint nh))). econstructor; split. eapply exec_straight_two with (rs2 := rs1). simpl. rewrite A. reflexivity. - simpl. change (rs1 EAX) with (rs EAX); rewrite B. - change (rs1 ECX) with (rs ECX); rewrite C. + 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 EAX) (rs ECX)). left; congruence. + 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#EDX <- Vzero)). + set (rs1 := nextinstr_nf (rs#RDX <- Vzero)). econstructor; split. eapply exec_straight_two with (rs2 := rs1). reflexivity. - simpl. change (rs1 EAX) with (rs EAX); rewrite B. - change (rs1 ECX) with (rs ECX); rewrite C. + 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 EAX) (rs ECX)). right; congruence. + 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#EDX <- (Vint nh))). + set (rs1 := nextinstr_nf (rs#RDX <- (Vint nh))). econstructor; split. eapply exec_straight_two with (rs2 := rs1). simpl. rewrite A. reflexivity. - simpl. change (rs1 EAX) with (rs EAX); rewrite B. - change (rs1 ECX) with (rs ECX); rewrite C. + 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 EAX) (rs ECX)). right; congruence. + 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#EDX <- Vzero)). + set (rs1 := nextinstr_nf (rs#RDX <- Vzero)). econstructor; split. eapply exec_straight_two with (rs2 := rs1). reflexivity. - simpl. change (rs1 EAX) with (rs EAX); rewrite B. - change (rs1 ECX) with (rs ECX); rewrite C. + 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_correct; eauto. intros EA. - TranslOp. rewrite nextinstr_inv; auto with asmgen. rewrite Pregmap.gss; auto. + 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. +(* 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. +(* 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 *) @@ -1106,12 +1338,20 @@ Transparent destroyed_by_op. 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 c0 rs ## (preg_of ## args) m). + split. rewrite T. destruct (eval_condition cond rs ## (preg_of ## args) m). rewrite Q. auto. simpl; auto. intros. transitivity (rs2 r); auto. @@ -1122,7 +1362,7 @@ Qed. 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#ESP) addr (map rs (map preg_of args)) = Some a -> + 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 @@ -1135,8 +1375,8 @@ Proof. 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.add (rs PC) Vone). - transitivity (Val.add ((rs#(preg_of dest) <- v) PC) Vone). + 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. @@ -1147,7 +1387,7 @@ 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#ESP) addr (map rs (map preg_of args)) = Some a -> + 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' @@ -1158,11 +1398,10 @@ Proof. 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_smallstore_correct; eauto. - intros. simpl. unfold exec_store. - destruct (eval_addrmode ge addr0 rs0); simpl; auto. rewrite Mem.store_signed_unsigned_8; auto. + eapply mk_storebyte_correct; eauto. + destruct (eval_addrmode ge x rs); simpl; auto. rewrite <- Mem.store_signed_unsigned_8; auto. (* int8unsigned *) - eapply mk_smallstore_correct; eauto. + eapply mk_storebyte_correct; eauto. (* int16signed *) econstructor; split. apply exec_straight_one. simpl. unfold exec_store. @@ -1180,6 +1419,10 @@ Proof. 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. diff --git a/ia32/CBuiltins.ml b/ia32/CBuiltins.ml index 79a839f3..1fe3b200 100644 --- a/ia32/CBuiltins.ml +++ b/ia32/CBuiltins.ml @@ -19,12 +19,15 @@ open C let builtins = { Builtins.typedefs = [ - "__builtin_va_list", TPtr(TVoid [], []) + (* Actually a struct passed by reference; equivalent to 3 64-bit words *) + "__builtin_va_list", TArray(TInt(IULong, []), Some 3L, []) ]; 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", @@ -79,8 +82,8 @@ let builtins = { ] } -let size_va_list = 4 -let va_list_scalar = true +let size_va_list = 3*8 +let va_list_scalar = false (* Expand memory references inside extended asm statements. Used in C2C. *) diff --git a/ia32/CombineOp.v b/ia32/CombineOp.v index cdd16071..34c1c9cc 100644 --- a/ia32/CombineOp.v +++ b/ia32/CombineOp.v @@ -2,7 +2,7 @@ (* *) (* The Compcert verified compiler *) (* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Xavier Leroy, INRIA Paris *) (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) @@ -14,10 +14,8 @@ during the [CSE] phase. *) Require Import Coqlib. -Require Import AST. -Require Import Integers. -Require Import Op. -Require Import CSEdomain. +Require Import AST Integers. +Require Import Op CSEdomain. Definition valnum := positive. @@ -72,23 +70,43 @@ Function combine_cond (cond: condition) (args: list valnum) : option(condition * | _, _ => None end. -Function combine_addr (addr: addressing) (args: list valnum) : option(addressing * list valnum) := +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) => Some(offset_addressing_total a n, ys) + | 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 addr args with + 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) @@ -104,6 +122,21 @@ Function combine_op (op: operation) (args: list valnum) : option(operation * lis | 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') diff --git a/ia32/CombineOpproof.v b/ia32/CombineOpproof.v index 8f600054..f59e582b 100644 --- a/ia32/CombineOpproof.v +++ b/ia32/CombineOpproof.v @@ -2,7 +2,7 @@ (* *) (* The Compcert verified compiler *) (* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Xavier Leroy, INRIA Paris *) (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) @@ -14,12 +14,8 @@ during the [CSE] phase. *) Require Import Coqlib. -Require Import Integers. -Require Import Values. -Require Import Memory. -Require Import Op. -Require Import RTL. -Require Import CSEdomain. +Require Import Integers Values Memory. +Require Import Op RTL CSEdomain. Require Import CombineOp. Section COMBINE. @@ -122,14 +118,36 @@ Proof. 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. - intros. functional inversion H; subst. - (* indexed - lea *) - UseGetSound. simpl. eapply eval_offset_addressing_total; eauto. + 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: @@ -139,13 +157,21 @@ Theorem combine_op_sound: Proof. intros. functional inversion H; subst. (* lea-lea *) - simpl. eapply combine_addr_sound; eauto. + 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. diff --git a/ia32/ConstpropOp.vp b/ia32/ConstpropOp.vp index a3de748c..c35d3def 100644 --- a/ia32/ConstpropOp.vp +++ b/ia32/ConstpropOp.vp @@ -2,7 +2,7 @@ (* *) (* The Compcert verified compiler *) (* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Xavier Leroy, INRIA Paris *) (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) @@ -13,15 +13,32 @@ (** Strength reduction for operators and conditions. This is the machine-dependent part of [Constprop]. *) -Require Import Coqlib. -Require Import Compopts. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Op. -Require Import Registers. +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 @@ -40,6 +57,14 @@ Nondetfunction cond_strength_reduction (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. @@ -61,53 +86,120 @@ Nondetfunction make_cmp (c: condition) (args: list reg) (vl: list aval) := make_cmp_base c args vl end. -Nondetfunction addr_strength_reduction +(** 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 (Int.add n ofs), nil) + (Aglobal symb (Ptrofs.add n (Ptrofs.repr ofs)), nil) | Aindexed ofs, r1 :: nil, Ptr(Stk n) :: nil => - (Ainstack (Int.add n ofs), nil) + (Ainstack (Ptrofs.add n (Ptrofs.repr ofs)), nil) | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: I n2 :: nil => - (Aglobal symb (Int.add (Int.add n1 n2) ofs), 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 (Int.add (Int.add n1 n2) ofs), 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 (Int.add (Int.add n1 n2) ofs), 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 (Int.add (Int.add n1 n2) ofs), 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 (Int.add n1 ofs), r2 :: nil) + (Abased symb (Ptrofs.add n1 (Ptrofs.repr ofs)), r2 :: nil) | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: Ptr(Gl symb n2) :: nil => - (Abased symb (Int.add n2 ofs), r1 :: nil) - | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: v2 :: nil => - (Aindexed (Int.add n1 ofs), r2 :: nil) - | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil => - (Aindexed (Int.add n2 ofs), r1 :: 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 (Int.add (Int.add n1 (Int.mul n2 sc)) ofs), 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 (Int.add n1 ofs), r2 :: nil) - | Aindexed2scaled sc ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil => - (Aindexed (Int.add (Int.mul n2 sc) ofs), r1 :: nil) + (Abasedscaled sc symb (Ptrofs.add n1 (Ptrofs.repr ofs)), r2 :: nil) | Abased id ofs, r1 :: nil, I n1 :: nil => - (Aglobal id (Int.add ofs n1), nil) + (Aglobal id (Ptrofs.add ofs (Ptrofs.of_int n1)), nil) | Abasedscaled sc id ofs, r1 :: nil, I n1 :: nil => - (Aglobal id (Int.add ofs (Int.mul sc 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 n), 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) @@ -173,6 +265,64 @@ Definition make_moduimm n (r1 r2: reg) := | 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_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) @@ -216,8 +366,26 @@ Nondetfunction op_strength_reduction | 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 addr args vl in + 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 + | 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 diff --git a/ia32/ConstpropOpproof.v b/ia32/ConstpropOpproof.v index 3dfb8ccf..4175d2f9 100644 --- a/ia32/ConstpropOpproof.v +++ b/ia32/ConstpropOpproof.v @@ -2,7 +2,7 @@ (* *) (* The Compcert verified compiler *) (* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Xavier Leroy, INRIA Paris *) (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) @@ -12,26 +12,11 @@ (** Correctness proof for operator strength reduction. *) -Require Import Coqlib. -Require Import Compopts. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Events. -Require Import Op. -Require Import Registers. -Require Import RTL. -Require Import ValueDomain. +Require Import Coqlib Compopts. +Require Import Integers Floats Values Memory Globalenvs Events. +Require Import Op Registers RTL ValueDomain. Require Import ConstpropOp. -(** We now show that strength reduction over operators and addressing - modes preserve semantics: the strength-reduced operations and - addressings evaluate to the same values as the original ones if the - actual arguments match the static approximations used for strength - reduction. *) - Section STRENGTH_REDUCTION. Variable bc: block_classification. @@ -73,6 +58,10 @@ Ltac SimplVM := 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); @@ -92,6 +81,43 @@ Ltac 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 -> @@ -104,64 +130,175 @@ Proof. - 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_correct: +Lemma addr_strength_reduction_32_generic_correct: forall addr args vl res, vl = map (fun r => AE.get r ae) args -> - eval_addressing ge (Vptr sp Int.zero) addr e##args = Some res -> - let (addr', args') := addr_strength_reduction addr args vl in - exists res', eval_addressing ge (Vptr sp Int.zero) addr' e##args' = Some res' /\ Val.lessdef res res'. -Proof. - intros until res. unfold addr_strength_reduction. - destruct (addr_strength_reduction_match addr args vl); simpl; - intros VL EA; InvApproxRegs; SimplVM; try (inv EA). -- rewrite Genv.shift_symbol_address. econstructor; split. eauto. apply Val.add_lessdef; auto. -- econstructor; split; eauto. rewrite Int.add_zero_l. - change (Vptr sp (Int.add n ofs)) with (Val.add (Vptr sp n) (Vint ofs)). apply Val.add_lessdef; auto. -- econstructor; split; eauto. rewrite Int.add_assoc. rewrite Genv.shift_symbol_address. - rewrite Val.add_assoc. apply Val.add_lessdef; auto. -- econstructor; split; eauto. - fold (Val.add (Vint n1) e#r2). rewrite (Val.add_commut (Vint n1)). - rewrite Genv.shift_symbol_address. apply Val.add_lessdef; auto. - rewrite Int.add_commut. rewrite Genv.shift_symbol_address. apply Val.add_lessdef; auto. -- econstructor; split; eauto. rewrite Int.add_zero_l. rewrite Int.add_assoc. - change (Vptr sp (Int.add n1 (Int.add n2 ofs))) - with (Val.add (Vptr sp n1) (Vint (Int.add n2 ofs))). - rewrite Val.add_assoc. apply Val.add_lessdef; auto. -- econstructor; split; eauto. rewrite Int.add_zero_l. - fold (Val.add (Vint n1) e#r2). rewrite (Int.add_commut n1). - change (Vptr sp (Int.add (Int.add n2 n1) ofs)) - with (Val.add (Val.add (Vint n1) (Vptr sp n2)) (Vint ofs)). - apply Val.add_lessdef; auto. apply Val.add_lessdef; auto. -- econstructor; split; eauto. rewrite Genv.shift_symbol_address. + 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. - rewrite Val.add_commut. apply Val.add_lessdef; auto. -- econstructor; split; eauto. rewrite Genv.shift_symbol_address. - rewrite (Val.add_commut e#r1). rewrite ! Val.add_assoc. - apply Val.add_lessdef; auto. rewrite Val.add_commut. apply Val.add_lessdef; auto. -- fold (Val.add (Vint n1) e#r2). econstructor; split; eauto. - rewrite (Val.add_commut (Vint n1)). rewrite Val.add_assoc. - apply Val.add_lessdef; eauto. -- econstructor; split; eauto. rewrite ! Val.add_assoc. - apply Val.add_lessdef; eauto. -- econstructor; split; eauto. rewrite Int.add_assoc. - rewrite Genv.shift_symbol_address. apply Val.add_lessdef; auto. - econstructor; split; eauto. - rewrite Genv.shift_symbol_address. rewrite ! Val.add_assoc. apply Val.add_lessdef; auto. - rewrite Val.add_commut; auto. + 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. -- econstructor; split; eauto. rewrite Genv.shift_symbol_address. auto. -- econstructor; split; eauto. rewrite Genv.shift_symbol_address. rewrite Int.mul_commut; auto. -- econstructor; 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 Int.zero) op' e##args' m = Some v + 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. @@ -174,7 +311,7 @@ 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 Int.zero) op' e##args' m = Some v + 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. @@ -206,19 +343,20 @@ Qed. Lemma make_addimm_correct: forall n r, let (op, args) := make_addimm n r in - exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.add e#r (Vint n)) v. + 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. - exists (Val.add e#r (Vint n)); auto. + 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 Int.zero) op e##args m = Some v /\ Val.lessdef (Val.shl e#r1 (Vint n)) v. + 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. @@ -232,7 +370,7 @@ 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 Int.zero) op e##args m = Some v /\ Val.lessdef (Val.shr e#r1 (Vint n)) v. + 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. @@ -246,7 +384,7 @@ 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 Int.zero) op e##args m = Some v /\ Val.lessdef (Val.shru e#r1 (Vint n)) v. + 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. @@ -259,7 +397,7 @@ Qed. Lemma make_mulimm_correct: forall n r1, let (op, args) := make_mulimm n r1 in - exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.mul e#r1 (Vint n)) v. + 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. @@ -276,7 +414,7 @@ Lemma make_divimm_correct: 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 Int.zero) op e##args m = Some w /\ Val.lessdef v w. + 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:?. @@ -291,7 +429,7 @@ Lemma make_divuimm_correct: 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 Int.zero) op e##args m = Some w /\ Val.lessdef v w. + 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:?. @@ -305,7 +443,7 @@ Lemma make_moduimm_correct: 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 Int.zero) op e##args m = Some w /\ Val.lessdef v w. + 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:?. @@ -317,7 +455,7 @@ 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 Int.zero) op e##args m = Some v /\ Val.lessdef (Val.and e#r (Vint n)) v. + 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. @@ -342,7 +480,7 @@ Qed. Lemma make_orimm_correct: forall n r, let (op, args) := make_orimm n r in - exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.or e#r (Vint n)) v. + 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. @@ -355,7 +493,7 @@ Qed. Lemma make_xorimm_correct: forall n r, let (op, args) := make_xorimm n r in - exists v, eval_operation ge (Vptr sp Int.zero) op e##args m = Some v /\ Val.lessdef (Val.xor e#r (Vint n)) v. + 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. @@ -365,11 +503,157 @@ Proof. 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_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 Int.zero) op e##args m = Some v /\ Val.lessdef (Val.mulf e#r1 e#r2) v. + 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. @@ -382,7 +666,7 @@ 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 Int.zero) op e##args m = Some v /\ Val.lessdef (Val.mulf e#r1 e#r2) v. + 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. @@ -396,7 +680,7 @@ 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 Int.zero) op e##args m = Some v /\ Val.lessdef (Val.mulfs e#r1 e#r2) v. + 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. @@ -409,7 +693,7 @@ 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 Int.zero) op e##args m = Some v /\ Val.lessdef (Val.mulfs e#r1 e#r2) v. + 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. @@ -423,7 +707,7 @@ 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 Int.zero) op e##args m = Some v /\ Val.lessdef (Val.sign_ext 8 e#r) v. + 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. @@ -437,7 +721,7 @@ 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 Int.zero) op e##args m = Some v /\ Val.lessdef (Val.zero_ext 8 e#r) v. + 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. @@ -451,7 +735,7 @@ 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 Int.zero) op e##args m = Some v /\ Val.lessdef (Val.sign_ext 16 e#r) v. + 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. @@ -465,7 +749,7 @@ 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 Int.zero) op e##args m = Some v /\ Val.lessdef (Val.zero_ext 16 e#r) v. + 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. @@ -478,9 +762,9 @@ 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 Int.zero) op e##args m = Some v -> + 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 Int.zero) op' e##args' m = Some w /\ Val.lessdef v w. + 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. @@ -523,8 +807,45 @@ Proof. (* shru *) InvApproxRegs; SimplVM; inv H0. apply make_shruimm_correct; auto. (* lea *) - exploit addr_strength_reduction_correct; eauto. - destruct (addr_strength_reduction addr args0 vl0) as [addr' args']. + 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. +(* 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. diff --git a/ia32/Conventions1.v b/ia32/Conventions1.v index 08a86815..dbc8b064 100644 --- a/ia32/Conventions1.v +++ b/ia32/Conventions1.v @@ -2,7 +2,7 @@ (* *) (* The Compcert verified compiler *) (* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Xavier Leroy, INRIA Paris *) (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) @@ -13,11 +13,8 @@ (** Function calling conventions and other conventions regarding the use of machine registers and stack slots. *) -Require Import Coqlib. -Require Import Decidableplus. -Require Import AST. -Require Import Events. -Require Import Locations. +Require Import Coqlib Decidableplus. +Require Import AST Machregs Locations. (** * Classification of machine registers *) @@ -26,23 +23,37 @@ Require Import Locations. - 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 application binary interface (ABI) in our choice - of callee- and caller-save registers. + 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 | SI | DI | BP => true + | 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 := AX :: CX :: DX :: nil. +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 := X0 :: X1 :: X2 :: X3 :: X4 :: X5 :: X6 :: X7 :: 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 := BX :: SI :: DI :: BP :: 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. @@ -52,6 +63,14 @@ Definition destroyed_at_call := 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 @@ -68,15 +87,16 @@ Definition dummy_float_reg := X0. (**r Used in [Regalloc]. *) 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 conventions. *) + implement the standard x86-32 and x86-64 conventions. *) (** ** Location of function result *) -(** 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. *) +(** 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 (s: signature) : rpair mreg := +Definition loc_result_32 (s: signature) : rpair mreg := match s.(sig_res) with | None => One AX | Some (Tint | Tany32) => One AX @@ -85,13 +105,27 @@ Definition loc_result (s: signature) : rpair mreg := | 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. destruct (sig_res sig) as [[]|]; auto. + 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 *) @@ -100,8 +134,8 @@ 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. destruct (sig_res s) as [[]|]; simpl; auto. + 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. *) @@ -110,17 +144,32 @@ 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 + | 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; unfold loc_result; destruct (sig_res sg) as [[]|]; auto. intuition congruence. + 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 *) -(** All arguments are passed on stack. (Snif.) *) +(** In the x86-32 ABI, all arguments are passed on stack. (Snif.) *) -Fixpoint loc_arguments_rec +Fixpoint loc_arguments_32 (tyl: list typ) (ofs: Z) {struct tyl} : list (rpair loc) := match tyl with | nil => nil @@ -129,27 +178,77 @@ Fixpoint loc_arguments_rec | Tlong => Twolong (S Outgoing (ofs + 1) Tint) (S Outgoing ofs Tint) | _ => One (S Outgoing ofs ty) end - :: loc_arguments_rec tys (ofs + typesize ty) + :: 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) := - loc_arguments_rec s.(sig_args) 0. + 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_rec +Fixpoint size_arguments_32 (tyl: list typ) (ofs: Z) {struct tyl} : Z := match tyl with | nil => ofs - | ty :: tys => size_arguments_rec tys (ofs + typesize ty) + | 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 := - size_arguments_rec s.(sig_args) 0. + 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. *) @@ -161,19 +260,26 @@ Definition loc_argument_acceptable (l: loc) : Prop := | _ => False end. -Definition loc_argument_charact (ofs: Z) (l: loc) : Prop := +Definition loc_argument_32_charact (ofs: Z) (l: loc) : Prop := match l with | S Outgoing ofs' ty => ofs' >= ofs /\ typealign ty = 1 | _ => False end. -Remark loc_arguments_rec_charact: +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_rec tyl ofs) -> forall_rpair (loc_argument_charact 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_charact ofs2 l -> ofs1 <= ofs2 -> loc_argument_charact ofs1 l). + 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_rec; intros. + induction tyl as [ | ty tyl]; simpl loc_arguments_32; intros. - contradiction. - destruct H. + destruct ty; subst p; simpl; omega. @@ -182,23 +288,73 @@ Proof. * 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. - exploit loc_arguments_rec_charact; eauto. - assert (X: forall l, loc_argument_charact 0 l -> loc_argument_acceptable l). + 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. } - destruct p; simpl; intuition auto. + 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_rec_above: - forall tyl ofs0, ofs0 <= size_arguments_rec tyl ofs0. +Remark size_arguments_32_above: + forall tyl ofs0, ofs0 <= size_arguments_32 tyl ofs0. Proof. induction tyl; simpl; intros. omega. @@ -206,23 +362,45 @@ Proof. 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. - apply size_arguments_rec_above. + destruct Archi.ptr64; [apply size_arguments_64_above|apply size_arguments_32_above]. 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. +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. - intros until ty. unfold loc_arguments, size_arguments. generalize (sig_args s) 0. - induction l as [ | t l]; simpl; intros x IN. + 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_rec_above]. ++ apply Zle_trans with (x + typesize t); [|apply size_arguments_32_above]. Ltac decomp := match goal with | [ H: _ \/ _ |- _ ] => destruct H; decomp @@ -233,8 +411,63 @@ Proof. + 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. - reflexivity. + unfold loc_arguments; destruct Archi.ptr64; reflexivity. Qed. diff --git a/ia32/Machregs.v b/ia32/Machregs.v index 3a6ae674..34d88328 100644 --- a/ia32/Machregs.v +++ b/ia32/Machregs.v @@ -31,12 +31,13 @@ Require Import Op. Inductive mreg: Type := (** Allocatable integer regs *) - | AX: mreg | BX: mreg | CX: mreg | DX: mreg | SI: mreg | DI: mreg | BP: mreg + | 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: mreg | X1: mreg | X2: mreg | X3: mreg - | X4: mreg | X5: mreg | X6: mreg | X7: mreg + | 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: mreg (**r top of x87 FP stack *). + | FP0. Lemma mreg_eq: forall (r1 r2: mreg), {r1 = r2} + {r1 <> r2}. Proof. decide equality. Defined. @@ -44,7 +45,9 @@ 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: @@ -55,7 +58,7 @@ Proof. 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 @@ -63,8 +66,11 @@ Instance Finite_mreg : Finite mreg := { Definition mreg_type (r: mreg): typ := match r with - | AX | BX | CX | DX | SI | DI | BP => Tany32 - | X0 | X1 | X2 | X3 | X4 | X5 | X6 | X7 | FP0 => Tany64 + | 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. @@ -75,9 +81,10 @@ Module IndexedMreg <: INDEXED_TYPE. Definition index (r: mreg): positive := match r with | AX => 1 | BX => 2 | CX => 3 | DX => 4 | SI => 5 | DI => 6 | BP => 7 - | X0 => 8 | X1 => 9 | X2 => 10 | X3 => 11 - | X4 => 12 | X5 => 13 | X6 => 14 | X7 => 15 - | FP0 => 16 + | 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. @@ -94,10 +101,16 @@ Definition is_stack_reg (r: mreg) : bool := 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 := @@ -112,7 +125,7 @@ Definition register_by_name (s: string) : option mreg := Definition destroyed_by_op (op: operation): list mreg := match op with - | Ocast8signed | Ocast8unsigned | Ocast16signed | Ocast16unsigned => AX :: nil + | Ocast8signed | Ocast8unsigned => AX :: nil | Omulhs => AX :: DX :: nil | Omulhu => AX :: DX :: nil | Odiv => AX :: DX :: nil @@ -120,6 +133,10 @@ Definition destroyed_by_op (op: operation): list mreg := | Omod => AX :: DX :: nil | Omodu => AX :: DX :: nil | Oshrximm _ => CX :: nil + | Odivl => AX :: DX :: nil + | Odivlu => AX :: DX :: nil + | Omodl => AX :: DX :: nil + | Omodlu => AX :: DX :: nil | Ocmp _ => AX :: CX :: nil | _ => nil end. @@ -129,9 +146,9 @@ Definition destroyed_by_load (chunk: memory_chunk) (addr: addressing): list mreg Definition destroyed_by_store (chunk: memory_chunk) (addr: addressing): list mreg := match chunk with - | Mint8signed | Mint8unsigned => AX :: CX :: nil + | Mint8signed | Mint8unsigned => if Archi.ptr64 then nil else AX :: CX :: nil | _ => nil - end. + end. Definition destroyed_by_cond (cond: condition): list mreg := nil. @@ -153,21 +170,21 @@ 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) => AX :: CX :: nil + | EF_vstore (Mint8unsigned|Mint8signed) => + if Archi.ptr64 then nil else AX :: CX :: nil | EF_builtin name sg => - if string_dec name "__builtin_write16_reversed" - || string_dec name "__builtin_write32_reversed" - then CX :: DX :: nil else nil + 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] *) - DX :: FP0 :: nil. - -Definition destroyed_at_indirect_call: list mreg := - nil. + AX :: FP0 :: nil. Definition destroyed_by_setstack (ty: typ): list mreg := match ty with @@ -175,8 +192,11 @@ Definition destroyed_by_setstack (ty: typ): list mreg := | _ => nil end. +Definition destroyed_at_indirect_call: list mreg := + nil. + Definition temp_for_parent_frame: mreg := - DX. + AX. Definition mregs_for_operation (op: operation): list (option mreg) * option mreg := match op with @@ -190,6 +210,13 @@ Definition mregs_for_operation (op: operation): list (option mreg) * option mreg | Oshr => (None :: Some CX :: nil, None) | Oshru => (None :: Some CX :: nil, None) | Oshrximm _ => (Some AX :: nil, Some AX) + | 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) | _ => (nil, None) end. @@ -205,6 +232,8 @@ Definition mregs_for_builtin (ef: external_function): list (option mreg) * list (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 (nil, nil) | _ => (nil, nil) @@ -213,7 +242,6 @@ Definition mregs_for_builtin (ef: external_function): list (option mreg) * list Global Opaque destroyed_by_op destroyed_by_load destroyed_by_store destroyed_by_cond destroyed_by_jumptable destroyed_by_builtin - destroyed_at_indirect_call destroyed_by_setstack destroyed_at_function_entry temp_for_parent_frame mregs_for_operation mregs_for_builtin. @@ -225,6 +253,7 @@ Definition two_address_op (op: operation) : bool := match op with | Omove => false | Ointconst _ => false + | Olongconst _ => false | Ofloatconst _ => false | Osingleconst _ => false | Oindirectsymbol _ => false @@ -259,6 +288,35 @@ Definition two_address_op (op: operation) : bool := | 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 + | 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 + | Oshrlu => true + | Oshrluimm _ => true + | Ororlimm _ => true + | Oleal addr => false | Onegf => true | Oabsf => true | Oaddf => true @@ -277,9 +335,10 @@ Definition two_address_op (op: operation) : bool := | Ofloatofint => false | Ointofsingle => false | Osingleofint => false - | Omakelong => false - | Olowlong => false - | Ohighlong => false + | Olongoffloat => false + | Ofloatoflong => false + | Olongofsingle => false + | Osingleoflong => false | Ocmp c => false end. diff --git a/ia32/NeedOp.v b/ia32/NeedOp.v index 07eec160..9a75cba8 100644 --- a/ia32/NeedOp.v +++ b/ia32/NeedOp.v @@ -1,15 +1,20 @@ +(* *********************************************************************) +(* *) +(* 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. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Op. -Require Import NeedDomain. -Require Import RTL. - -(** Neededness analysis for IA32 operators *) +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. @@ -20,7 +25,7 @@ Definition needs_of_condition (cond: condition): list nval := | _ => nil end. -Definition needs_of_addressing (addr: addressing) (nv: nval): list nval := +Definition needs_of_addressing_32 (addr: addressing) (nv: nval): list nval := match addr with | Aindexed n => op1 (modarith nv) | Aindexed2 n => op2 (modarith nv) @@ -32,10 +37,26 @@ Definition needs_of_addressing (addr: addressing) (nv: nval): list nval := | 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 @@ -64,15 +85,42 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Oshruimm n => op1 (shruimm nv n) | Ororimm n => op1 (ror nv n) | Oshldimm n => op1 (default nv) - | Olea addr => needs_of_addressing addr 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) + | Odivl => op2 (default nv) + | Odivlu => op2 (default nv) + | Omodl => op2 (default nv) + | 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) + | 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) - | Omakelong => op2 (default nv) - | Olowlong | Ohighlong => op1 (default nv) + | Olongoffloat | Ofloatoflong | Olongofsingle | Osingleoflong => op1 (default nv) | Ocmp c => needs_of_condition c end. @@ -117,19 +165,19 @@ Proof. try (eapply default_needs_of_condition_sound; eauto; fail); simpl in *; FuncInv; InvAgree. - eapply maskzero_sound; eauto. -- destruct (Val.maskzero_bool v i) as [b'|] eqn:MZ; try discriminate. +- destruct (Val.maskzero_bool v n) as [b'|] eqn:MZ; try discriminate. erewrite maskzero_sound; eauto. Qed. -Lemma needs_of_addressing_sound: - forall (ge: genv) sp addr args v nv args', - eval_addressing ge (Vptr sp Int.zero) addr args = Some v -> - vagree_list args args' (needs_of_addressing addr nv) -> +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_addressing ge (Vptr sp Int.zero) addr args' = Some v' + eval_addressing32 ge (Vptr sp Ptrofs.zero) addr args' = Some v' /\ vagree v v' nv. Proof. - unfold needs_of_addressing; intros. + 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. @@ -137,13 +185,23 @@ Proof. 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 Int.zero) op args m = Some v -> + 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 Int.zero) op args' m' = Some 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); @@ -166,8 +224,12 @@ Proof. - apply shrimm_sound; auto. - apply shruimm_sound; auto. - apply ror_sound; auto. -- eapply needs_of_addressing_sound; eauto. -- destruct (eval_condition c args m) as [b|] eqn:EC; simpl in H2. +- 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. @@ -176,7 +238,7 @@ 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 Int.zero) op (arg1 :: args) m = Some v -> + 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. diff --git a/ia32/Op.v b/ia32/Op.v index f21d7c6a..ed96c132 100644 --- a/ia32/Op.v +++ b/ia32/Op.v @@ -17,7 +17,7 @@ - [operation]: arithmetic and logical operations; - [addressing]: addressing modes for load and store operations. - These types are IA32-specific and correspond roughly to what the + 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 @@ -38,135 +38,179 @@ Set Implicit Arguments. (** Conditions (boolean-valued operators). *) Inductive condition : Type := - | Ccomp: comparison -> condition (**r signed integer comparison *) - | Ccompu: comparison -> condition (**r unsigned integer comparison *) - | Ccompimm: comparison -> int -> condition (**r signed integer comparison with a constant *) - | Ccompuimm: comparison -> int -> condition (**r unsigned integer comparison with a constant *) - | Ccompf: comparison -> condition (**r 64-bit floating-point comparison *) - | Cnotcompf: comparison -> condition (**r negation of a floating-point comparison *) - | Ccompfs: comparison -> condition (**r 32-bit floating-point comparison *) - | Cnotcompfs: comparison -> condition (**r negation of a floating-point comparison *) - | Cmaskzero: int -> condition (**r test [(arg & constant) == 0] *) - | Cmasknotzero: int -> condition. (**r test [(arg & constant) != 0] *) + | 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: int -> addressing (**r Address is [r1 + offset] *) - | Aindexed2: int -> addressing (**r Address is [r1 + r2 + offset] *) - | Ascaled: int -> int -> addressing (**r Address is [r1 * scale + offset] *) - | Aindexed2scaled: int -> int -> addressing - (**r Address is [r1 + r2 * scale + offset] *) - | Aglobal: ident -> int -> addressing (**r Address is [symbol + offset] *) - | Abased: ident -> int -> addressing (**r Address is [symbol + offset + r1] *) - | Abasedscaled: int -> ident -> int -> addressing (**r Address is [symbol + offset + r1 * scale] *) - | Ainstack: int -> addressing. (**r Address is [stack_pointer + offset] *) + | 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: operation (**r [rd = r1] *) - | Ointconst: int -> operation (**r [rd] is set to the given integer constant *) - | Ofloatconst: float -> operation (**r [rd] is set to the given float constant *) - | Osingleconst: float32 -> operation (**r [rd] is set to the given float constant *) - | Oindirectsymbol: ident -> operation (**r [rd] is set to the address of the symbol *) -(*c Integer arithmetic: *) - | Ocast8signed: operation (**r [rd] is 8-bit sign extension of [r1] *) - | Ocast8unsigned: operation (**r [rd] is 8-bit zero extension of [r1] *) - | Ocast16signed: operation (**r [rd] is 16-bit sign extension of [r1] *) - | Ocast16unsigned: operation (**r [rd] is 16-bit zero extension of [r1] *) - | Oneg: operation (**r [rd = - r1] *) - | Osub: operation (**r [rd = r1 - r2] *) - | Omul: operation (**r [rd = r1 * r2] *) - | Omulimm: int -> operation (**r [rd = r1 * n] *) - | Omulhs: operation (**r [rd = high part of r1 * r2, signed] *) - | Omulhu: operation (**r [rd = high part of r1 * r2, unsigned] *) - | Odiv: operation (**r [rd = r1 / r2] (signed) *) - | Odivu: operation (**r [rd = r1 / r2] (unsigned) *) - | Omod: operation (**r [rd = r1 % r2] (signed) *) - | Omodu: operation (**r [rd = r1 % r2] (unsigned) *) - | Oand: operation (**r [rd = r1 & r2] *) - | Oandimm: int -> operation (**r [rd = r1 & n] *) - | Oor: operation (**r [rd = r1 | r2] *) - | Oorimm: int -> operation (**r [rd = r1 | n] *) - | Oxor: operation (**r [rd = r1 ^ r2] *) - | Oxorimm: int -> operation (**r [rd = r1 ^ n] *) - | Onot: operation (**r [rd = ~r1] *) - | Oshl: operation (**r [rd = r1 << r2] *) - | Oshlimm: int -> operation (**r [rd = r1 << n] *) - | Oshr: operation (**r [rd = r1 >> r2] (signed) *) - | Oshrimm: int -> operation (**r [rd = r1 >> n] (signed) *) - | Oshrximm: int -> operation (**r [rd = r1 / 2^n] (signed) *) - | Oshru: operation (**r [rd = r1 >> r2] (unsigned) *) - | Oshruimm: int -> operation (**r [rd = r1 >> n] (unsigned) *) - | Ororimm: int -> operation (**r rotate right immediate *) - | Oshldimm: int -> operation (**r [rd = r1 << n | r2 >> (32-n)] *) - | Olea: addressing -> operation (**r effective address *) + | 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] *) + | 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) *) + | 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: operation (**r [rd = - r1] *) - | Oabsf: operation (**r [rd = abs(r1)] *) - | Oaddf: operation (**r [rd = r1 + r2] *) - | Osubf: operation (**r [rd = r1 - r2] *) - | Omulf: operation (**r [rd = r1 * r2] *) - | Odivf: operation (**r [rd = r1 / r2] *) - | Onegfs: operation (**r [rd = - r1] *) - | Oabsfs: operation (**r [rd = abs(r1)] *) - | Oaddfs: operation (**r [rd = r1 + r2] *) - | Osubfs: operation (**r [rd = r1 - r2] *) - | Omulfs: operation (**r [rd = r1 * r2] *) - | Odivfs: operation (**r [rd = r1 / r2] *) - | Osingleoffloat: operation (**r [rd] is [r1] truncated to single-precision float *) - | Ofloatofsingle: operation (**r [rd] is [r1] extended to double-precision float *) + | 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: operation (**r [rd = signed_int_of_float64(r1)] *) - | Ofloatofint: operation (**r [rd = float64_of_signed_int(r1)] *) - | Ointofsingle: operation (**r [rd = signed_int_of_float32(r1)] *) - | Osingleofint: operation (**r [rd = float32_of_signed_int(r1)] *) -(*c Manipulating 64-bit integers: *) - | Omakelong: operation (**r [rd = r1 << 32 | r2] *) - | Olowlong: operation (**r [rd = low-word(r1)] *) - | Ohighlong: operation (**r [rd = high-word(r1)] *) + | 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: condition -> operation. (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) - -(** Derived operators. *) - -Definition Oaddrsymbol (id: ident) (ofs: int) : operation := Olea (Aglobal id ofs). -Definition Oaddrstack (ofs: int) : operation := Olea (Ainstack ofs). -Definition Oaddimm (n: int) : operation := Olea (Aindexed n). + | 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; intro. + 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 Int.eq_dec; intro. - assert (forall (x y: ident), {x=y}+{x<>y}). exact peq. + 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; intro. - generalize Float.eq_dec; intro. - generalize Float32.eq_dec; intro. - generalize Int64.eq_dec; intro. + generalize Int.eq_dec Int64.eq_dec Float.eq_dec Float32.eq_dec; intros. decide equality. - apply peq. + 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 @@ -180,6 +224,10 @@ Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool | 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 @@ -189,38 +237,65 @@ Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool | _, _ => None end. -Definition eval_addressing +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 n)) + Some (Val.add v1 (Vint (Int.repr n))) | Aindexed2 n, v1::v2::nil => - Some (Val.add (Val.add v1 v2) (Vint n)) + Some (Val.add (Val.add v1 v2) (Vint (Int.repr n))) | Ascaled sc ofs, v1::nil => - Some (Val.add (Val.mul v1 (Vint sc)) (Vint ofs)) + 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 sc)) (Vint ofs))) + Some(Val.add v1 (Val.add (Val.mul v2 (Vint (Int.repr sc))) (Vint (Int.repr ofs)))) | Aglobal s ofs, nil => - Some (Genv.symbol_address genv s ofs) + if Archi.ptr64 then None else Some (Genv.symbol_address genv s ofs) | Abased s ofs, v1::nil => - Some (Val.add (Genv.symbol_address genv s ofs) v1) + if Archi.ptr64 then None else Some (Val.add (Genv.symbol_address genv s ofs) v1) | Abasedscaled sc s ofs, v1::nil => - Some (Val.add (Genv.symbol_address genv s ofs) (Val.mul v1 (Vint sc))) + 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 => - Some(Val.add sp (Vint ofs)) + 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 Int.zero) + | 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) @@ -252,7 +327,36 @@ Definition eval_operation | 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_addressing genv sp addr vl + | 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)) + | 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)) + | 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) @@ -271,21 +375,48 @@ Definition eval_operation | Ofloatofint, v1::nil => Val.floatofint v1 | Ointofsingle, v1::nil => Val.intofsingle v1 | Osingleofint, v1::nil => Val.singleofint v1 - | Omakelong, v1::v2::nil => Some(Val.longofwords v1 v2) - | Olowlong, v1::nil => Some(Val.loword v1) - | Ohighlong, v1::nil => Some(Val.hiword 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; FuncInv + 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; FuncInv + 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. @@ -298,6 +429,10 @@ Definition type_of_condition (c: condition) : list typ := | 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 @@ -306,25 +441,30 @@ Definition type_of_condition (c: condition) : list typ := | Cmasknotzero _ => Tint :: nil end. -Definition type_of_addressing (addr: addressing) : list typ := +Definition type_of_addressing_gen (tyA: typ) (addr: addressing): list typ := match addr with - | Aindexed _ => Tint :: nil - | Aindexed2 _ => Tint :: Tint :: nil - | Ascaled _ _ => Tint :: nil - | Aindexed2scaled _ _ => Tint :: Tint :: nil + | Aindexed _ => tyA :: nil + | Aindexed2 _ => tyA :: tyA :: nil + | Ascaled _ _ => tyA :: nil + | Aindexed2scaled _ _ => tyA :: tyA :: nil | Aglobal _ _ => nil - | Abased _ _ => Tint :: nil - | Abasedscaled _ _ _ => Tint :: 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, Tint) + | Oindirectsymbol _ => (nil, Tptr) | Ocast8signed => (Tint :: nil, Tint) | Ocast8unsigned => (Tint :: nil, Tint) | Ocast16signed => (Tint :: nil, Tint) @@ -355,7 +495,36 @@ Definition type_of_operation (op: operation) : list typ * typ := | Oshruimm _ => (Tint :: nil, Tint) | Ororimm _ => (Tint :: nil, Tint) | Oshldimm _ => (Tint :: Tint :: nil, Tint) - | Olea addr => (type_of_addressing addr, 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) + | 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) + | 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) @@ -374,9 +543,10 @@ Definition type_of_operation (op: operation) : list typ * typ := | Ofloatofint => (Tint :: nil, Tfloat) | Ointofsingle => (Tsingle :: nil, Tint) | Osingleofint => (Tint :: nil, Tsingle) - | Omakelong => (Tint :: Tint :: nil, Tlong) - | Olowlong => (Tlong :: nil, Tint) - | Ohighlong => (Tlong :: nil, Tint) + | Olongoffloat => (Tfloat :: nil, Tlong) + | Ofloatoflong => (Tlong :: nil, Tfloat) + | Olongofsingle => (Tsingle :: nil, Tlong) + | Osingleoflong => (Tlong :: nil, Tsingle) | Ocmp c => (type_of_condition c, Tint) end. @@ -389,22 +559,45 @@ Section SOUNDNESS. Variable A V: Type. Variable genv: Genv.t A V. -Lemma type_of_addressing_sound: +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_addressing genv sp addr vl = Some 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 with (try exact I). - intros. destruct addr; simpl in H; FuncInv; subst; simpl. - destruct v0... - destruct v0... destruct v1... destruct v1... - destruct v0... - destruct v0... destruct v1... destruct v1... - unfold Genv.symbol_address; destruct (Genv.find_symbol genv i)... - unfold Genv.symbol_address; destruct (Genv.find_symbol genv i)... - unfold Genv.symbol_address; destruct (Genv.find_symbol genv i)... destruct v0... - destruct v0... - unfold Genv.symbol_address; destruct (Genv.find_symbol genv i0)... destruct v0... - destruct sp... +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: @@ -419,13 +612,17 @@ Proof with (try exact I). exact I. exact I. exact I. - unfold Genv.symbol_address; destruct (Genv.find_symbol genv 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. destruct (eq_block b b0)... + 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... @@ -444,16 +641,49 @@ Proof with (try exact I). destruct v0... destruct v0... destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... - destruct v0; simpl... destruct (Int.ltu i 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 i Int.iwordsize)... - destruct v0; simpl in H0; try discriminate. destruct (Int.ltu i (Int.repr 31)); inv H0... + 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 i 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; 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; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... + destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')... destruct v0... - destruct v0; simpl... destruct (Int.ltu i Int.iwordsize)... - destruct v1; simpl... destruct (Int.ltu (Int.sub Int.iwordsize i) Int.iwordsize)... - eapply type_of_addressing_sound; eauto. + eapply type_of_addressing64_sound; eauto. destruct v0... destruct v0... destruct v0; destruct v1... @@ -472,10 +702,11 @@ Proof with (try exact I). 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; destruct v1... - destruct v0... - destruct v0... - destruct (eval_condition c vl m); simpl... destruct b... + 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. @@ -512,6 +743,10 @@ Definition negate_condition (cond: condition): condition := | 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 @@ -529,25 +764,30 @@ Proof. 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 i) as [[]|]; 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: int) (addr: addressing) := +Definition shift_stack_addressing (delta: Z) (addr: addressing) := match addr with - | Ainstack ofs => Ainstack (Int.add delta ofs) + | Ainstack ofs => Ainstack (Ptrofs.add ofs (Ptrofs.repr delta)) | _ => addr end. -Definition shift_stack_operation (delta: int) (op: operation) := +Definition shift_stack_operation (delta: Z) (op: operation) := match op with - | Olea addr => Olea (shift_stack_addressing delta addr) + | Olea addr => Olea (shift_stack_addressing delta addr) + | Oleal addr => Oleal (shift_stack_addressing delta addr) | _ => op end. @@ -560,75 +800,116 @@ 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. apply type_shift_stack_addressing. + intros. destruct op; auto; simpl; decEq; destruct a; auto. Qed. -Lemma eval_shift_stack_addressing: +Lemma eval_shift_stack_addressing32: forall F V (ge: Genv.t F V) sp addr vl delta, - eval_addressing ge sp (shift_stack_addressing delta addr) vl = - eval_addressing ge (Val.add sp (Vint delta)) addr vl. + 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. - rewrite Val.add_assoc. 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 sp (shift_stack_operation delta op) vl m = - eval_operation ge (Val.add sp (Vint delta)) op vl m. + 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. - apply eval_shift_stack_addressing. + 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]. On PowerPC and ARM, this may be undefined, in which case - [None] is returned. On IA32, it is always defined, but we keep the - same interface. *) + by [addr]. This may be undefined if an offset overflows, in which case + [None] is returned. *) -Definition offset_addressing_total (addr: addressing) (delta: int) : addressing := +Definition offset_addressing_total (addr: addressing) (delta: Z) : addressing := match addr with - | Aindexed n => Aindexed (Int.add n delta) - | Aindexed2 n => Aindexed2 (Int.add n delta) - | Ascaled sc n => Ascaled sc (Int.add n delta) - | Aindexed2scaled sc n => Aindexed2scaled sc (Int.add n delta) - | Aglobal s n => Aglobal s (Int.add n delta) - | Abased s n => Abased s (Int.add n delta) - | Abasedscaled sc s n => Abasedscaled sc s (Int.add n delta) - | Ainstack n => Ainstack (Int.add n delta) + | 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: int) : option addressing := - Some(offset_addressing_total addr delta). +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: +Lemma eval_offset_addressing_total_32: forall (F V: Type) (ge: Genv.t F V) sp addr args delta v, - eval_addressing ge sp addr args = Some v -> - eval_addressing ge sp (offset_addressing_total addr delta) args = - Some(Val.add v (Vint delta)). + 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. - intros. destruct addr; simpl in *; FuncInv; subst. - rewrite Val.add_assoc; auto. - rewrite !Val.add_assoc; auto. - rewrite !Val.add_assoc; auto. - rewrite !Val.add_assoc; auto. - unfold Genv.symbol_address. destruct (Genv.find_symbol ge i); auto. - unfold Genv.symbol_address. destruct (Genv.find_symbol ge i); auto. - rewrite Val.add_assoc. rewrite Val.add_permut. rewrite Val.add_commut. auto. - unfold Genv.symbol_address. destruct (Genv.find_symbol ge i0); auto. - rewrite Val.add_assoc. rewrite Val.add_permut. rewrite Val.add_commut. auto. - rewrite Val.add_assoc. auto. + 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 -> - eval_addressing ge sp addr' args = Some(Val.add v (Vint delta)). + Archi.ptr64 = false -> + eval_addressing ge sp addr' args = Some(Val.add v (Vint (Int.repr delta))). Proof. - intros. unfold offset_addressing in H; inv H. - eapply eval_offset_addressing_total; eauto. + 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. *) @@ -637,8 +918,11 @@ 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. @@ -646,8 +930,10 @@ Definition is_trivial_op (op: operation) : bool := Definition op_depends_on_memory (op: operation) : bool := match op with - | Ocmp (Ccompu _) => true - | Ocmp (Ccompuimm _ _) => true + | Ocmp (Ccompu _) => negb Archi.ptr64 + | Ocmp (Ccompuimm _ _) => negb Archi.ptr64 + | Ocmp (Ccomplu _) => Archi.ptr64 + | Ocmp (Ccompluimm _ _) => Archi.ptr64 | _ => false end. @@ -657,7 +943,8 @@ Lemma op_depends_on_memory_correct: eval_operation ge sp op args m1 = eval_operation ge sp op args m2. Proof. intros until m2. destruct op; simpl; try congruence. - destruct c; simpl; auto; 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 *) @@ -674,6 +961,7 @@ 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. @@ -692,13 +980,30 @@ 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, Genv.symbol_address; destruct addr; try rewrite agree_on_symbols; - reflexivity. + unfold eval_addressing; destruct Archi.ptr64; auto using eval_addressing32_preserved, eval_addressing64_preserved. Qed. Lemma eval_operation_preserved: @@ -708,7 +1013,8 @@ Proof. intros. unfold eval_operation; destruct op; auto. unfold Genv.symbol_address. rewrite agree_on_symbols. auto. - apply eval_addressing_preserved. + apply eval_addressing32_preserved. + apply eval_addressing64_preserved. Qed. End GENV_TRANSF. @@ -728,30 +1034,30 @@ Variable m2: mem. Hypothesis valid_pointer_inj: forall b1 ofs b2 delta, f b1 = Some(b2, delta) -> - Mem.valid_pointer m1 b1 (Int.unsigned ofs) = true -> - Mem.valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. + 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 (Int.unsigned ofs) = true -> - Mem.weak_valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. + 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 (Int.unsigned ofs) = true -> - 0 <= Int.unsigned ofs + Int.unsigned (Int.repr delta) <= Int.max_unsigned. + 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 (Int.unsigned ofs1) = true -> - Mem.valid_pointer m1 b2 (Int.unsigned ofs2) = true -> + 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' \/ - Int.unsigned (Int.add ofs1 (Int.repr delta1)) <> Int.unsigned (Int.add ofs2 (Int.repr delta2)). + Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned (Ptrofs.add ofs2 (Ptrofs.repr delta2)). Ltac InvInject := match goal with @@ -775,16 +1081,20 @@ Lemma eval_condition_inj: 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. - 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. +- 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 := @@ -794,6 +1104,36 @@ Ltac TrivialExists := | _ => 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, @@ -804,15 +1144,7 @@ Lemma eval_addressing_inj: eval_addressing ge1 sp1 addr vl1 = Some v1 -> exists v2, eval_addressing ge2 sp2 addr vl2 = Some v2 /\ Val.inject f v1 v2. Proof. - intros. destruct addr; simpl in H2; simpl; FuncInv; InvInject; TrivialExists. - apply Values.Val.add_inject; auto. - apply Values.Val.add_inject; auto. apply Values.Val.add_inject; auto. - apply Values.Val.add_inject; auto. inv H5; simpl; auto. - apply Values.Val.add_inject; auto. apply Values.Val.add_inject; auto. inv H3; simpl; auto. - apply H; simpl; auto. - apply Values.Val.add_inject; auto. apply H; simpl; auto. - apply Values.Val.add_inject; auto. apply H; simpl; auto. inv H5; simpl; auto. - apply Values.Val.add_inject; auto. + unfold eval_addressing; intros. destruct Archi.ptr64; eauto using eval_addressing32_inj, eval_addressing64_inj. Qed. Lemma eval_operation_inj: @@ -832,10 +1164,7 @@ Proof. inv H4; simpl; auto. inv H4; simpl; auto. inv H4; simpl; auto. - inv H4; inv H2; simpl; auto. econstructor; eauto. - rewrite Int.sub_add_l. auto. - destruct (eq_block b1 b0); auto. subst. rewrite H1 in H0. inv H0. rewrite dec_eq_true. - rewrite Int.sub_shifted. auto. + apply Val.sub_inject; auto. inv H4; inv H2; simpl; auto. inv H4; simpl; auto. inv H4; inv H2; simpl; auto. @@ -856,17 +1185,50 @@ Proof. 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 i 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 i 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 i (Int.repr 31)); inv H1. TrivialExists. + 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 i 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. destruct (Int.ltu i Int.iwordsize); auto. - inv H2; simpl; auto. destruct (Int.ltu (Int.sub Int.iwordsize i) Int.iwordsize); auto. - eapply eval_addressing_inj; eauto. + 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 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; 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. @@ -887,10 +1249,13 @@ Proof. 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; inv H2; simpl; auto. - inv H4; simpl; auto. - inv H4; simpl; auto. - subst v1. destruct (eval_condition c vl1 m1) eqn:?. + 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. @@ -909,40 +1274,40 @@ 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 (Int.unsigned ofs) = true -> - Mem.valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. + 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 Int.add_zero. eapply Mem.valid_pointer_extends; eauto. + 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 (Int.unsigned ofs) = true -> - Mem.weak_valid_pointer m2 b2 (Int.unsigned (Int.add ofs (Int.repr delta))) = true. + 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 Int.add_zero. eapply Mem.weak_valid_pointer_extends; eauto. + 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 (Int.unsigned ofs) = true -> - 0 <= Int.unsigned ofs + Int.unsigned (Int.repr delta) <= Int.max_unsigned. + 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 Int.unsigned_range_2. + 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 (Int.unsigned ofs1) = true -> - Mem.valid_pointer m1 b2 (Int.unsigned ofs2) = true -> + 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' \/ - Int.unsigned(Int.add ofs1 (Int.repr delta1)) <> Int.unsigned(Int.add ofs2 (Int.repr delta2)). + Ptrofs.unsigned(Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned(Ptrofs.add ofs2 (Ptrofs.repr delta2)). Proof. intros. inv H2; inv H3. auto. Qed. @@ -1022,7 +1387,7 @@ Remark symbol_address_inject: Proof. intros. unfold Genv.symbol_address. destruct (Genv.find_symbol genv id) eqn:?; auto. exploit (proj1 globals); eauto. intros. - econstructor; eauto. rewrite Int.add_zero; auto. + econstructor; eauto. rewrite Ptrofs.add_zero; auto. Qed. Lemma eval_condition_inject: @@ -1042,34 +1407,36 @@ Qed. Lemma eval_addressing_inject: forall addr vl1 vl2 v1, Val.inject_list f vl1 vl2 -> - eval_addressing genv (Vptr sp1 Int.zero) addr vl1 = Some v1 -> + eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = Some v1 -> exists v2, - eval_addressing genv (Vptr sp2 Int.zero) (shift_stack_addressing (Int.repr delta) addr) vl2 = Some 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. simpl. - eapply eval_addressing_inj with (sp1 := Vptr sp1 Int.zero); eauto. + 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 Int.zero) op vl1 m1 = Some v1 -> + eval_operation genv (Vptr sp1 Ptrofs.zero) op vl1 m1 = Some v1 -> exists v2, - eval_operation genv (Vptr sp2 Int.zero) (shift_stack_operation (Int.repr delta) op) vl2 m2 = Some 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 Int.zero) (m1 := m1); eauto. + 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 index 2a80e3d4..42c8b3e5 100644 --- a/ia32/PrintOp.ml +++ b/ia32/PrintOp.ml @@ -33,7 +33,15 @@ let print_condition reg pp = function | (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 %ld" reg r1 (comparison_name c) (camlint_of_coqint n) + 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]) -> @@ -51,22 +59,23 @@ let print_condition reg pp = function let print_addressing reg pp = function | Aindexed n, [r1] -> - fprintf pp "%a + %ld" reg r1 (camlint_of_coqint n) + fprintf pp "%a + %s" reg r1 (Z.to_string n) | Aindexed2 n, [r1; r2] -> - fprintf pp "%a + %a + %ld" reg r1 reg r2 (camlint_of_coqint n) + fprintf pp "%a + %a + %s" reg r1 reg r2 (Z.to_string n) | Ascaled(sc,n), [r1] -> - fprintf pp "%a * %ld + %ld" reg r1 (camlint_of_coqint sc) (camlint_of_coqint n) + fprintf pp "%a * %s + %s" reg r1 (Z.to_string sc) (Z.to_string n) | Aindexed2scaled(sc, n), [r1; r2] -> - fprintf pp "%a + %a * %ld + %ld" reg r1 reg r2 (camlint_of_coqint sc) (camlint_of_coqint n) - | Aglobal(id, ofs), [] -> fprintf pp "%s + %ld" (extern_atom id) (camlint_of_coqint ofs) - | Abased(id, ofs), [r1] -> fprintf pp "%s + %ld + %a" (extern_atom id) (camlint_of_coqint ofs) reg r1 - | Abasedscaled(sc,id, ofs), [r1] -> fprintf pp "%s + %ld + %a * %ld" (extern_atom id) (camlint_of_coqint ofs) reg r1 (camlint_of_coqint sc) - | Ainstack ofs, [] -> fprintf pp "stack(%ld)" (camlint_of_coqint ofs) + 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 "" 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) @@ -78,6 +87,8 @@ let print_operation reg pp = function | 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 @@ -88,6 +99,7 @@ let print_operation reg pp = function | 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 @@ -97,7 +109,35 @@ let print_operation reg pp = function | 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) + | Olea addr, args -> print_addressing reg pp (addr, args); fprintf pp " (lea)" + | 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) + | 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 < fprintf pp "%a < fprintf pp "%a >>ls %a" reg r1 reg r2 + | Oshrlimm n, [r1] -> fprintf pp "%a >>ls %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 " (leal)" | 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 @@ -116,12 +156,10 @@ let print_operation reg pp = function | Ofloatofint, [r1] -> fprintf pp "floatofint(%a)" reg r1 | Ointofsingle, [r1] -> fprintf pp "intofsingle(%a)" reg r1 | Osingleofint, [r1] -> fprintf pp "singleofint(%a)" reg r1 - | 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 - | Onot, [r1] -> fprintf pp "not(%a)" reg r1 - | Omulhs, [r1;r2] -> fprintf pp "mulhs(%a,%a)" reg r1 reg r2 - | Omulhu, [r1;r2] -> fprintf pp "mulhu(%a,%a)" reg r1 reg r2 + | 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 "" diff --git a/ia32/SelectLong.vp b/ia32/SelectLong.vp new file mode 100644 index 00000000..c28777e8 --- /dev/null +++ b/ia32/SelectLong.vp @@ -0,0 +1,365 @@ +(* *********************************************************************) +(* *) +(* 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) := + 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 (Ororimm 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 (Int.repr (Int64.unsigned i)) + | i :: j :: nil => + Elet e2 (addl (shllimm (Eletvar 0) (Int.repr (Int64.unsigned i))) + (shllimm (Eletvar 0) (Int.repr (Int64.unsigned j)))) + | _ => + Eop (Omullimm n1) (e2:::Enil) + end. + +Nondetfunction mullimm (n1: int64) (e2: expr) := + 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 divl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.divl e1 e2 else + match is_longconst e1, is_longconst e2 with + | Some n1, Some n2 => longconst (Int64.divs n1 n2) + | _, _ => Eop Odivl (e1:::e2:::Enil) + end. + +Definition modl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.modl e1 e2 else + match is_longconst e1, is_longconst e2 with + | Some n1, Some n2 => longconst (Int64.mods n1 n2) + | _, _ => Eop Omodl (e1:::e2:::Enil) + end. + +Definition divlu (e1 e2: expr) := + if Archi.splitlong then SplitLong.divlu e1 e2 else + let default := Eop Odivlu (e1:::e2:::Enil) in + match is_longconst e1, is_longconst e2 with + | Some n1, Some n2 => longconst (Int64.divu n1 n2) + | _, Some n2 => + match Int64.is_power2 n2 with + | Some l => shrluimm e1 (Int.repr (Int64.unsigned l)) + | None => default + end + | _, _ => default + end. + +Definition modlu (e1 e2: expr) := + if Archi.splitlong then SplitLong.modlu e1 e2 else + let default := Eop Omodlu (e1:::e2:::Enil) in + match is_longconst e1, is_longconst e2 with + | Some n1, Some n2 => longconst (Int64.modu n1 n2) + | _, Some n2 => + match Int64.is_power2 n2 with + | Some l => andl e1 (longconst (Int64.sub n2 Int64.one)) + | None => default + end + | _, _ => default + end. + +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 new file mode 100644 index 00000000..634da83a --- /dev/null +++ b/ia32/SelectLongproof.v @@ -0,0 +1,304 @@ +(* *********************************************************************) +(* *) +(* 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 a n, is_longconst a = Some n -> a = Eop (Olongconst n) Enil. +Proof with (try discriminate). + unfold is_longconst; intros. destruct a... destruct o... destruct e0... congruence. +Qed. + +Lemma is_longconst_inv: + forall v a n le, + is_longconst a = Some n -> eval_expr ge sp e m le a v -> v = Vlong n. +Proof. + intros. rewrite (is_longconst_sound _ _ H) in H0. 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_inv 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. +Admitted. + +Theorem eval_orlimm: forall n, unary_constructor_sound (orlimm n) (fun v => Val.orl v (Vlong n)). +Admitted. + +Theorem eval_orl: binary_constructor_sound orl Val.orl. +Admitted. + +Theorem eval_xorlimm: forall n, unary_constructor_sound (xorlimm n) (fun v => Val.xorl v (Vlong n)). +Admitted. + +Theorem eval_xorl: binary_constructor_sound xorl Val.xorl. +Admitted. + +Theorem eval_shllimm: forall n, unary_constructor_sound (fun e => shllimm e n) (fun v => Val.shll v (Vint n)). +Admitted. + +Theorem eval_shrluimm: forall n, unary_constructor_sound (fun e => shrluimm e n) (fun v => Val.shrlu v (Vint n)). +Admitted. + +Theorem eval_shrlimm: forall n, unary_constructor_sound (fun e => shrlimm e n) (fun v => Val.shrl v (Vint n)). +Admitted. + +Theorem eval_shll: binary_constructor_sound shll Val.shll. +Admitted. + +Theorem eval_shrlu: binary_constructor_sound shrlu Val.shrlu. +Admitted. + +Theorem eval_shrl: binary_constructor_sound shrl Val.shrl. +Admitted. + +Theorem eval_negl: unary_constructor_sound negl Val.negl. +Admitted. + +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)). +Admitted. + +Theorem eval_mullimm: forall n, unary_constructor_sound (mullimm n) (fun v => Val.mull v (Vlong n)). +Admitted. + +Theorem eval_mull: binary_constructor_sound mull Val.mull. +Admitted. + +Theorem eval_divl: partial_binary_constructor_sound divl Val.divls. +Admitted. + +Theorem eval_modl: partial_binary_constructor_sound modl Val.modls. +Admitted. + +Theorem eval_divlu: partial_binary_constructor_sound divlu Val.divlu. +Admitted. + +Theorem eval_modlu: partial_binary_constructor_sound modlu Val.modlu. +Admitted. + +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_inv; eauto)); + try (assert (y = Vlong n2) by (eapply is_longconst_inv; 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_inv; eauto)); + try (assert (y = Vlong n2) by (eapply is_longconst_inv; 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. +Admitted. + +Theorem eval_floatoflong: partial_unary_constructor_sound floatoflong Val.floatoflong. +Admitted. + +Theorem eval_longofsingle: partial_unary_constructor_sound longofsingle Val.longofsingle. +Admitted. + +Theorem eval_singleoflong: partial_unary_constructor_sound singleoflong Val.singleoflong. +Admitted. + +End CMCONSTR. diff --git a/ia32/SelectOp.vp b/ia32/SelectOp.vp index bc331b9c..db546d99 100644 --- a/ia32/SelectOp.vp +++ b/ia32/SelectOp.vp @@ -2,7 +2,7 @@ (* *) (* The Compcert verified compiler *) (* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Xavier Leroy, INRIA Paris *) (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) @@ -38,33 +38,33 @@ Require Import Coqlib. Require Import Compopts. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Op. -Require Import CminorSel. +Require Import AST Integers Floats. +Require Import Op CminorSel. Open Local Scope cminorsel_scope. (** ** Constants **) -(** External oracle to determine whether a symbol is external and must - be addressed through [Oaddrsymbol], or is local and can be addressed - through [Olea Aglobal]. This is to accommodate MacOS X's limitations - on references to data symbols imported from shared libraries. *) +(** 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 addrsymbol (id: ident) (ofs: int) := +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 Int.eq ofs Int.zero + if Ptrofs.eq ofs Ptrofs.zero then Eop (Oindirectsymbol id) Enil - else Eop (Olea (Aindexed ofs)) (Eop (Oindirectsymbol id) Enil ::: Enil) + else Eop (Olea_ptr (Aindexed (Ptrofs.unsigned ofs))) (Eop (Oindirectsymbol id) Enil ::: Enil) else - Eop (Olea (Aglobal id ofs)) Enil. + Eop (Olea_ptr (Aglobal id ofs)) Enil. -Definition addrstack (ofs: int) := - Eop (Olea (Ainstack ofs)) Enil. +Definition addrstack (ofs: ptrofs) := + Eop (Olea_ptr (Ainstack ofs)) Enil. (** ** Integer logical negation *) @@ -81,8 +81,8 @@ 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 n)) args - | _ => Eop (Olea (Aindexed n)) (e ::: 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) := @@ -90,19 +90,19 @@ Nondetfunction add (e1: expr) (e2: expr) := | 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 (Int.add n1 n2))) (t1:::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 (Int.add n1 n2))) (t1:::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 (Int.add n1 n2))) (t2:::t1:::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 (Int.add ofs n1))) (t1:::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 (Int.add ofs 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 (Int.add ofs n1))) (t1:::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 (Int.add ofs 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) => @@ -112,7 +112,7 @@ Nondetfunction add (e1: expr) (e2: expr) := | t1, Eop (Olea (Aindexed n)) (t2:::Enil) => Eop (Olea (Aindexed2 n)) (t1:::t2:::Enil) | _, _ => - Eop (Olea (Aindexed2 Int.zero)) (e1:::e2:::Enil) + Eop (Olea (Aindexed2 0)) (e1:::e2:::Enil) end. (** ** Opposite *) @@ -129,11 +129,11 @@ 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.sub n1 n2) (Eop Osub (t1:::t2:::Enil)) + addimm (Int.repr (n1 - n2)) (Eop Osub (t1:::t2:::Enil)) | Eop (Olea (Aindexed n1)) (t1:::Enil), t2 => - addimm n1 (Eop Osub (t1:::t2:::Enil)) + addimm (Int.repr n1) (Eop Osub (t1:::t2:::Enil)) | t1, Eop (Olea (Aindexed n2)) (t2:::Enil) => - addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) + addimm (Int.repr (-n2)) (Eop Osub (t1:::t2:::Enil)) | _, _ => Eop Osub (e1:::e2:::Enil) end. @@ -157,11 +157,12 @@ Nondetfunction shlimm (e1: expr) (n: int) := else Eop (Oshlimm n) (e1:::Enil) | Eop (Olea (Aindexed n1)) (t1:::Enil) => if shift_is_scale n - then Eop (Olea (Ascaled (Int.shl Int.one n) (Int.shl n1 n))) (t1:::Enil) + 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.shl Int.one n) Int.zero)) (e1:::Enil) + then Eop (Olea (Ascaled (Int.unsigned (Int.shl Int.one n)) 0)) (e1:::Enil) else Eop (Oshlimm n) (e1:::Enil) end. @@ -214,7 +215,7 @@ Nondetfunction mulimm (n1: int) (e2: expr) := 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 n2) (mulimm_base n1 t2) + | Eop (Olea (Aindexed n2)) (t2:::Enil) => addimm (Int.mul n1 (Int.repr n2)) (mulimm_base n1 t2) | _ => mulimm_base n1 e2 end. @@ -503,8 +504,11 @@ Nondetfunction singleofintu (e: expr) := Nondetfunction addressing (chunk: memory_chunk) (e: expr) := match e with - | Eop (Olea addr) args => (addr, args) - | _ => (Aindexed Int.zero, e:::Enil) + | 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 *) @@ -512,8 +516,11 @@ Nondetfunction addressing (chunk: memory_chunk) (e: expr) := Nondetfunction builtin_arg (e: expr) := match e with | Eop (Ointconst n) Enil => BA_int n - | Eop (Olea (Aglobal id ofs)) Enil => BA_addrglobal id ofs - | Eop (Olea (Ainstack ofs)) Enil => BA_addrstack ofs + | 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) diff --git a/ia32/SelectOpproof.v b/ia32/SelectOpproof.v index bcfc13c9..e201d207 100644 --- a/ia32/SelectOpproof.v +++ b/ia32/SelectOpproof.v @@ -25,6 +25,7 @@ Require Import CminorSel. Require Import SelectOp. Open Local Scope cminorsel_scope. +Local Transparent Archi.ptr64. (** * Useful lemmas and tactics *) @@ -111,27 +112,35 @@ Definition binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> va 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 Int.eq Int.eq_spec ofs Int.zero. + predSpec Ptrofs.eq Ptrofs.eq_spec ofs Ptrofs.zero. subst. EvalOp. - EvalOp. econstructor. EvalOp. simpl; eauto. econstructor. simpl. - unfold Genv.symbol_address. destruct (Genv.find_symbol ge id); auto. - simpl. rewrite Int.add_commut. rewrite Int.add_zero. auto. - 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.add sp (Vint ofs)) v. + exists v, eval_expr ge sp e m le (addrstack ofs) v /\ Val.lessdef (Val.offset_ptr sp ofs) v. Proof. - intros. unfold addrstack. econstructor; split. - EvalOp. simpl; eauto. - auto. + intros. unfold addrstack. TrivialExists. rewrite eval_Olea_ptr. apply eval_addressing_Ainstack. Qed. Theorem eval_notint: unary_constructor_sound notint Val.notint. @@ -148,36 +157,46 @@ 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. rewrite Int.add_zero. 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. eapply eval_offset_addressing_total; eauto. - TrivialExists. + 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 Val.add_permut_4. auto. - subst. TrivialExists. simpl. rewrite Val.add_assoc. decEq; decEq. rewrite Val.add_permut. auto. - subst. TrivialExists. simpl. rewrite Val.add_permut_4. rewrite <- Val.add_permut. rewrite <- Val.add_assoc. auto. - subst. TrivialExists. simpl. rewrite Genv.shift_symbol_address. - rewrite Val.add_commut. rewrite Val.add_assoc. decEq. decEq. apply Val.add_commut. - subst. TrivialExists. simpl. rewrite Genv.shift_symbol_address. rewrite Val.add_assoc. - decEq; decEq. apply Val.add_commut. - subst. TrivialExists. simpl. rewrite Genv.shift_symbol_address. rewrite Val.add_commut. - rewrite Val.add_assoc. decEq; decEq. apply Val.add_commut. - subst. TrivialExists. simpl. rewrite Genv.shift_symbol_address. - rewrite Val.add_assoc. decEq; decEq. apply Val.add_commut. - subst. TrivialExists. simpl. rewrite Val.add_permut. rewrite Val.add_assoc. +- 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. +- 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. @@ -187,13 +206,16 @@ Proof. 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. 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 (fun v => Val.sub Vzero v). +Theorem eval_negint: unary_constructor_sound negint Val.neg. Proof. red; intros until x. unfold negint. case (negint_match a); intros; InvEval. TrivialExists. @@ -222,13 +244,15 @@ Proof. 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 n1). auto. + 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.add_zero. rewrite Int.shl_mul. auto. + rewrite Int.repr_unsigned. rewrite Int.add_zero. rewrite Int.shl_mul. auto. TrivialExists. intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. auto. @@ -287,29 +311,26 @@ 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). - generalize (Int.one_bits_range n). - destruct (Int.one_bits n). - intros. TrivialExists. - destruct l. - intros. rewrite H1. simpl. - rewrite Int.add_zero. - replace (Vint (Int.shl Int.one i)) with (Val.shl Vone (Vint i)). rewrite Val.shl_mul. - apply eval_shlimm. auto. simpl. rewrite H0; auto with coqlib. - destruct l. - intros. rewrite H1. simpl. + 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 i0 (x :: le) (Eletvar 0) x). constructor; auto. intros [v2 [A2 B2]]. + 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 Int.add_zero. - replace (Vint (Int.add (Int.shl Int.one i) (Int.shl Int.one i0))) - with (Val.add (Val.shl Vone (Vint i)) (Val.shl Vone (Vint i0))). + 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. repeat rewrite H0; auto with coqlib. - intros. TrivialExists. + simpl. rewrite ! R by auto with coqlib. auto. + TrivialExists. Qed. Theorem eval_mulimm: @@ -326,7 +347,7 @@ Proof. 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 n2) le (mulimm_base n t2) v'). auto. intros [v'' [A2 B2]]. + 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. @@ -893,9 +914,26 @@ Theorem eval_addressing: eval_addressing ge sp mode vl = Some v end. Proof. - intros until v. unfold addressing; case (addressing_match a); intros; InvEval. - inv H. exists vl; auto. - exists (v :: nil); split. constructor; auto. constructor. subst; simpl. rewrite Int.add_zero; auto. + 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: @@ -906,11 +944,14 @@ Proof. intros until v. unfold builtin_arg; case (builtin_arg_match a); intros; InvEval. - constructor. - 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. simpl in H6; inv H6. constructor; auto. -- inv H. InvEval. simpl in H6. inv H6. 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. diff --git a/ia32/Stacklayout.v b/ia32/Stacklayout.v index f19f036c..44fd43b2 100644 --- a/ia32/Stacklayout.v +++ b/ia32/Stacklayout.v @@ -2,7 +2,7 @@ (* *) (* The Compcert verified compiler *) (* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Xavier Leroy, INRIA Paris *) (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) @@ -13,9 +13,11 @@ (** Machine- and ABI-dependent layout information for activation records. *) Require Import Coqlib. -Require Import Memory Separation. +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. @@ -29,16 +31,14 @@ Require Import Bounds. Definition fe_ofs_arg := 0. -(** Computation of the frame environment from the bounds of the current - function. *) - Definition make_env (b: bounds) : frame_env := - let olink := 4 * b.(bound_outgoing) in (* back link *) - let ocs := olink + 4 in (* callee-saves *) + 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)) 4 in (* return address *) - let sz := oretaddr + 4 in (* total size *) + 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; @@ -47,31 +47,31 @@ Definition make_env (b: bounds) : frame_env := fe_stack_data := ostkdata; fe_used_callee_save := b.(used_callee_save) |}. -(** Separation property *) - -Local Open Scope sep_scope. - 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 + 4) - ** range sp (fe_ofs_retaddr fe) (fe_ofs_retaddr fe + 4) + ** 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 (olink := 4 * b.(bound_outgoing)). - set (ocs := olink + 4). + 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)) 4). + 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 <= olink) by (unfold olink; omega). - assert (olink + 4 <= ocs) by (unfold ocs; omega). + 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). @@ -88,7 +88,7 @@ Local Opaque Z.add Z.mul sepconj range. rewrite sep_swap34. (* Apply range_split and range_split2 repeatedly *) unfold fe_ofs_arg. - apply range_split. omega. + 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. @@ -104,14 +104,17 @@ Lemma frame_env_range: 0 <= fe_stack_data fe /\ fe_stack_data fe + bound_stack_data b <= fe_size fe. Proof. intros; simpl. - set (olink := 4 * b.(bound_outgoing)). - set (ocs := olink + 4). + 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)) 4). + 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 <= olink) by (unfold olink; omega). - assert (olink + 4 <= ocs) by (unfold ocs; omega). + 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). @@ -125,18 +128,21 @@ Lemma frame_env_aligned: (8 | fe_ofs_arg) /\ (8 | fe_ofs_local fe) /\ (8 | fe_stack_data fe) - /\ (4 | fe_ofs_link fe) - /\ (4 | fe_ofs_retaddr fe). + /\ (align_chunk Mptr | fe_ofs_link fe) + /\ (align_chunk Mptr | fe_ofs_retaddr fe). Proof. intros; simpl. - set (olink := 4 * b.(bound_outgoing)). - set (ocs := olink + 4). + 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)) 4). + 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 Z.divide_factor_l. + split. apply align_divides; omega. apply align_divides; omega. Qed. diff --git a/ia32/TargetPrinter.ml b/ia32/TargetPrinter.ml index 4ffb701b..c3e70042 100644 --- a/ia32/TargetPrinter.ml +++ b/ia32/TargetPrinter.ml @@ -10,7 +10,7 @@ (* *) (* *********************************************************************) -(* Printing IA32 assembly code in asm syntax *) +(* Printing x86-64 assembly code in asm syntax *) open Printf open !Datatypes @@ -25,30 +25,41 @@ module StringSet = Set.Make(String) (* Basic printing functions used in definition of the systems *) -let int_reg_name = function - | EAX -> "%eax" | EBX -> "%ebx" | ECX -> "%ecx" | EDX -> "%edx" - | ESI -> "%esi" | EDI -> "%edi" | EBP -> "%ebp" | ESP -> "%esp" +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 int8_reg_name = function - | EAX -> "%al" | EBX -> "%bl" | ECX -> "%cl" | EDX -> "%dl" - | _ -> assert false +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 high_int8_reg_name = function - | EAX -> "%ah" | EBX -> "%bh" | ECX -> "%ch" | EDX -> "%dh" - | _ -> assert false +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 - | EAX -> "%ax" | EBX -> "%bx" | ECX -> "%cx" | EDX -> "%dx" - | ESI -> "%si" | EDI -> "%di" | EBP -> "%bp" | ESP -> "%sp" + | 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 ireg oc r = output_string oc (int_reg_name r) let ireg8 oc r = output_string oc (int8_reg_name r) -let high_ireg8 oc r = output_string oc (high_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 @@ -56,6 +67,8 @@ let preg oc = function | FR r -> freg oc r | _ -> assert false +let z oc n = output_string oc (Z.to_string n) + (* The comment deliminiter *) let comment = "#" @@ -68,7 +81,7 @@ module type SYSTEM = val name_of_section: section_name -> string val stack_alignment: int val print_align: out_channel -> int -> unit - val print_mov_ra: out_channel -> ireg -> ident -> 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 @@ -76,61 +89,6 @@ module type SYSTEM = val print_lcomm_decl: out_channel -> P.t -> Z.t -> int -> unit end -(* Printer functions for cygwin *) -module Cygwin_System : SYSTEM = - struct - - let raw_symbol oc s = - fprintf oc "_%s" s - - let symbol oc symb = - raw_symbol oc (extern_atom symb) - - let label oc lbl = - fprintf oc "L%d" lbl - - let name_of_section = function - | Section_text -> ".text" - | Section_data i | Section_small_data i -> - if i then ".data" else "COMM" - | Section_const i | Section_small_const i -> - if i then ".section .rdata,\"dr\"" else "COMM" - | Section_string -> ".section .rdata,\"dr\"" - | Section_literal -> ".section .rdata,\"dr\"" - | Section_jumptable -> ".text" - | Section_user(s, wr, ex) -> - sprintf ".section \"%s\", \"%s\"\n" - s (if ex then "xr" else if wr then "d" else "dr") - | Section_debug_info _ -> ".section .debug_info,\"dr\"" - | Section_debug_loc -> ".section .debug_loc,\"dr\"" - | Section_debug_line _ -> ".section .debug_line,\"dr\"" - | Section_debug_abbrev -> ".section .debug_abbrev,\"dr\"" - | Section_debug_ranges -> ".section .debug_ranges,\"dr\"" - | Section_debug_str-> assert false (* Should not be used *) - - let stack_alignment = 8 (* minimum is 4, 8 is better for perfs *) - - let print_align oc n = - fprintf oc " .align %d\n" n - - let print_mov_ra oc rd id = - fprintf oc " movl $%a, %a\n" symbol id ireg rd - - let print_fun_info _ _ = () - - let print_var_info _ _ = () - - let print_epilogue _ = () - - let print_comm_decl oc name sz al = - fprintf oc " .comm %a, %s, %d\n" symbol name (Z.to_string sz) 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 ELF *) module ELF_System : SYSTEM = struct @@ -161,13 +119,13 @@ module ELF_System : SYSTEM = | Section_debug_ranges -> ".section .debug_ranges,\"\",@progbits" | Section_debug_str -> ".section .debug_str,\"MS\",@progbits,1" - let stack_alignment = 8 (* minimum is 4, 8 is better for perfs *) + let stack_alignment = 16 let print_align oc n = fprintf oc " .align %d\n" n - let print_mov_ra oc rd id = - fprintf oc " movl $%a, %a\n" symbol id ireg rd + let print_mov_rs oc rd id = + fprintf oc " movq %a@GOTPCREL(%%rip), %a\n" symbol id ireg64 rd let print_fun_info = elf_print_fun_info @@ -228,26 +186,14 @@ module MacOS_System : SYSTEM = let print_align oc n = fprintf oc " .align %d\n" (log2 n) - let indirect_symbols : StringSet.t ref = ref StringSet.empty - - let print_mov_ra oc rd id = - 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 + let print_mov_rs oc rd id = + fprintf oc " movq %a@GOTPCREL(%%rip), %a\n" symbol id ireg64 rd let print_fun_info _ _ = () let print_var_info _ _ = () - let print_epilogue oc = - 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 + let print_epilogue oc = () let print_comm_decl oc name sz al = fprintf oc " .comm %a, %s, %d\n" @@ -269,27 +215,39 @@ module Target(System: SYSTEM):TARGET = let symbol_offset oc (symb, ofs) = symbol oc symb; - if ofs <> 0l then fprintf oc " + %ld" ofs + let ofs = Z.to_int64 ofs in + if ofs <> 0L then fprintf oc " + %Ld" ofs - - let addressing oc (Addrmode(base, shift, cst)) = + let addressing_gen ireg oc (Addrmode(base, shift, cst)) = begin match cst with | Coq_inl n -> - let n = camlint_of_coqint n in - fprintf oc "%ld" n + fprintf oc "%s" (Z.to_string n) | Coq_inr(id, ofs) -> - let ofs = camlint_of_coqint ofs in - if ofs = 0l - then symbol oc id - else fprintf oc "(%a + %ld)" symbol 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 coqint sc - | Some r1, Some(r2,sc) -> fprintf oc "(%a,%a,%a)" ireg r1 ireg r2 coqint sc + | 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" @@ -317,15 +275,28 @@ module Target(System: SYSTEM):TARGET = let print_file_line oc file line = print_file_line oc comment file line - - (* Built-in functions *) (* 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. *) + registers; preserve all registers except RCX, RDX, XMM6 and XMM7. *) + +(* Hack for large 64-bit immediates *) + + 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 *) @@ -334,15 +305,36 @@ module Target(System: SYSTEM):TARGET = let print_instruction oc = function (* Moves *) | Pmov_rr(rd, r1) -> - fprintf oc " movl %a, %a\n" ireg r1 ireg rd - | Pmov_ri(rd, n) -> - fprintf oc " movl $%ld, %a\n" (camlint_of_coqint n) ireg rd - | Pmov_ra(rd, id) -> - print_mov_ra oc rd id - | Pmov_rm(rd, a) | Pmov_rm_a(rd, a) -> - fprintf oc " movl %a, %a\n" addressing a ireg rd - | Pmov_mr(a, r1) | Pmov_mr_a(a, r1) -> - fprintf oc " movl %a, %a\n" ireg r1 addressing a + 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) -> @@ -366,112 +358,183 @@ module Target(System: SYSTEM):TARGET = | Pfldl_m(a) -> fprintf oc " fldl %a\n" addressing a | Pfstpl_m(a) -> - fprintf oc " fstpl %a\n" addressing 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 - | Pxchg_rr(r1, r2) -> - fprintf oc " xchgl %a, %a\n" ireg r1 ireg r2 (* 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 ireg rd + fprintf oc " movzbl %a, %a\n" ireg8 r1 ireg32 rd | Pmovzb_rm(rd, a) -> - fprintf oc " movzbl %a, %a\n" addressing a ireg rd + fprintf oc " movzbl %a, %a\n" addressing a ireg32 rd | Pmovsb_rr(rd, r1) -> - fprintf oc " movsbl %a, %a\n" ireg8 r1 ireg rd + fprintf oc " movsbl %a, %a\n" ireg8 r1 ireg32 rd | Pmovsb_rm(rd, a) -> - fprintf oc " movsbl %a, %a\n" addressing a ireg rd + fprintf oc " movsbl %a, %a\n" addressing a ireg32 rd | Pmovzw_rr(rd, r1) -> - fprintf oc " movzwl %a, %a\n" ireg16 r1 ireg rd + fprintf oc " movzwl %a, %a\n" ireg16 r1 ireg32 rd | Pmovzw_rm(rd, a) -> - fprintf oc " movzwl %a, %a\n" addressing a ireg rd + fprintf oc " movzwl %a, %a\n" addressing a ireg32 rd | Pmovsw_rr(rd, r1) -> - fprintf oc " movswl %a, %a\n" ireg16 r1 ireg rd + fprintf oc " movswl %a, %a\n" ireg16 r1 ireg32 rd | Pmovsw_rm(rd, a) -> - fprintf oc " movswl %a, %a\n" addressing a ireg rd + 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 ireg rd + fprintf oc " cvttsd2si %a, %a\n" freg r1 ireg32 rd | Pcvtsi2sd_fr(rd, r1) -> - fprintf oc " cvtsi2sd %a, %a\n" ireg r1 freg rd + fprintf oc " cvtsi2sd %a, %a\n" ireg32 r1 freg rd | Pcvttss2si_rf(rd, r1) -> - fprintf oc " cvttss2si %a, %a\n" freg r1 ireg rd + fprintf oc " cvttss2si %a, %a\n" freg r1 ireg32 rd | Pcvtsi2ss_fr(rd, r1) -> - fprintf oc " cvtsi2ss %a, %a\n" ireg r1 freg rd + 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 *) - | Plea(rd, a) -> - fprintf oc " leal %a, %a\n" addressing a ireg rd - | Pneg(rd) -> - fprintf oc " negl %a\n" ireg rd - | Psub_rr(rd, r1) -> - fprintf oc " subl %a, %a\n" ireg r1 ireg rd - | Pimul_rr(rd, r1) -> - fprintf oc " imull %a, %a\n" ireg r1 ireg rd - | Pimul_ri(rd, n) -> - fprintf oc " imull $%a, %a\n" coqint n ireg rd - | Pimul_r(r1) -> - fprintf oc " imull %a\n" ireg r1 - | Pmul_r(r1) -> - fprintf oc " mull %a\n" ireg r1 + | 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 + | Pmull_r(r1) -> + fprintf oc " mull %a\n" ireg32 r1 | Pcltd -> fprintf oc " cltd\n" - | Pdiv(r1) -> - fprintf oc " divl %a\n" ireg r1 - | Pidiv(r1) -> - fprintf oc " idivl %a\n" ireg r1 - | Pand_rr(rd, r1) -> - fprintf oc " andl %a, %a\n" ireg r1 ireg rd - | Pand_ri(rd, n) -> - fprintf oc " andl $%a, %a\n" coqint n ireg rd - | Por_rr(rd, r1) -> - fprintf oc " orl %a, %a\n" ireg r1 ireg rd - | Por_ri(rd, n) -> - fprintf oc " orl $%a, %a\n" coqint n ireg rd - | Pxor_r(rd) -> - fprintf oc " xorl %a, %a\n" ireg rd ireg rd - | Pxor_rr(rd, r1) -> - fprintf oc " xorl %a, %a\n" ireg r1 ireg rd - | Pxor_ri(rd, n) -> - fprintf oc " xorl $%a, %a\n" coqint n ireg rd - | Pnot(rd) -> - fprintf oc " notl %a\n" ireg rd - | Psal_rcl(rd) -> - fprintf oc " sall %%cl, %a\n" ireg rd - | Psal_ri(rd, n) -> - fprintf oc " sall $%a, %a\n" coqint n ireg rd - | Pshr_rcl(rd) -> - fprintf oc " shrl %%cl, %a\n" ireg rd - | Pshr_ri(rd, n) -> - fprintf oc " shrl $%a, %a\n" coqint n ireg rd - | Psar_rcl(rd) -> - fprintf oc " sarl %%cl, %a\n" ireg rd - | Psar_ri(rd, n) -> - fprintf oc " sarl $%a, %a\n" coqint n ireg rd + | 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 ireg r1 ireg rd - | Pror_ri(rd, n) -> - fprintf oc " rorl $%a, %a\n" coqint n ireg rd - | Pcmp_rr(r1, r2) -> - fprintf oc " cmpl %a, %a\n" ireg r2 ireg r1 - | Pcmp_ri(r1, n) -> - fprintf oc " cmpl $%a, %a\n" coqint n ireg r1 - | Ptest_rr(r1, r2) -> - fprintf oc " testl %a, %a\n" ireg r2 ireg r1 - | Ptest_ri(r1, n) -> - fprintf oc " testl $%a, %a\n" coqint n ireg r1 + 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 ireg 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 @@ -513,10 +576,8 @@ module Target(System: SYSTEM):TARGET = | Pjmp_l(l) -> fprintf oc " jmp %a\n" label (transl_label l) | Pjmp_s(f, sg) -> - assert (not sg.sig_cc.cc_structret); fprintf oc " jmp %a\n" symbol f | Pjmp_r(r, sg) -> - assert (not sg.sig_cc.cc_structret); fprintf oc " jmp *%a\n" ireg r | Pjcc(c, l) -> let l = transl_label l in @@ -529,40 +590,35 @@ module Target(System: SYSTEM):TARGET = fprintf oc "%a:\n" label l' | Pjmptbl(r, tbl) -> let l = new_label() in - fprintf oc " jmp *%a(, %a, 4)\n" label l ireg r; + fprintf oc " jmp *%a(, %a, 8)\n" label l ireg64 r; jumptables := (l, tbl) :: !jumptables | Pcall_s(f, sg) -> - fprintf oc " call %a\n" symbol f; - if sg.sig_cc.cc_structret then - fprintf oc " pushl %%eax\n" + fprintf oc " call %a\n" symbol f | Pcall_r(r, sg) -> - fprintf oc " call *%a\n" ireg r; - if sg.sig_cc.cc_structret then - fprintf oc " pushl %%eax\n" + fprintf oc " call *%a\n" ireg r | Pret -> - if (!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 + fprintf oc " ret\n" (* Instructions produced by Asmexpand *) - | Padc_ri (res,n) -> - fprintf oc " adcl $%ld, %a\n" (camlint_of_coqint n) ireg res; - | Padc_rr (res,a1) -> - fprintf oc " adcl %a, %a\n" ireg a1 ireg res; - | Padd_ri (res,n) -> - fprintf oc " addl $%ld, %a\n" (camlint_of_coqint n) ireg res - | Padd_rr (res,a1) -> - fprintf oc " addl %a, %a\n" ireg a1 ireg res; - | Padd_mi (addr,n) -> + | 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 - | Pbsf (res,a1) -> - fprintf oc " bsfl %a, %a\n" ireg a1 ireg res - | Pbsr (res,a1) -> - fprintf oc " bsrl %a, %a\n" ireg a1 ireg res - | Pbswap res -> - fprintf oc " bswap %a\n" ireg res + | 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 -> @@ -597,9 +653,9 @@ module Target(System: SYSTEM):TARGET = fprintf oc " minsd %a, %a\n" freg a1 freg res | Pmovb_rm (rd,a) -> fprintf oc " movb %a, %a\n" addressing a ireg8 rd - | Pmovq_mr(a, rs) -> + | Pmovsq_mr(a, rs) -> fprintf oc " movq %a, %a\n" freg rs addressing a - | Pmovq_rm(rd, a) -> + | Pmovsq_rm(rd, a) -> fprintf oc " movq %a, %a\n" addressing a freg rd | Pmovsb -> fprintf oc " movsb\n"; @@ -609,12 +665,14 @@ module Target(System: SYSTEM):TARGET = fprintf oc " movw %a, %a\n" addressing a ireg16 rd | Prep_movsl -> fprintf oc " rep movsl\n" - | Psbb_rr (res,a1) -> - fprintf oc " sbbl %a, %a\n" ireg a1 ireg res + | 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 - | Psub_ri (res,n) -> - fprintf oc " subl $%ld, %a\n" (camlint_of_coqint n) ireg 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) @@ -646,11 +704,11 @@ module Target(System: SYSTEM):TARGET = let print_jumptable oc (lbl, tbl) = fprintf oc "%a:" label lbl; List.iter - (fun l -> fprintf oc " .long %a\n" label (transl_label l)) + (fun l -> fprintf oc " .quad %a\n" label (transl_label l)) tbl in if !jumptables <> [] then begin section oc jmptbl; - print_align oc 4; + print_align oc 8; List.iter (print_jumptable oc) !jumptables; jumptables := [] end @@ -674,10 +732,9 @@ module Target(System: SYSTEM):TARGET = comment (camlfloat_of_coqfloat n) | Init_space n -> if Z.gt n Z.zero then - fprintf oc " .space %s\n" (Z.to_string n) + fprintf oc " .space %a\n" z n | Init_addrof(symb, ofs) -> - fprintf oc " .long %a\n" - symbol_offset (symb, camlint_of_coqint ofs) + fprintf oc " .quad %a\n" symbol_offset (symb, ofs) let print_align = print_align @@ -760,6 +817,5 @@ let sel_target () = | "macosx" -> (module MacOS_System:SYSTEM) | "linux" | "bsd" -> (module ELF_System:SYSTEM) - | "cygwin" -> (module Cygwin_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 index ad18c4f6..ce33341e 100644 --- a/ia32/ValueAOp.v +++ b/ia32/ValueAOp.v @@ -2,7 +2,7 @@ (* *) (* The Compcert verified compiler *) (* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Xavier Leroy, INRIA Paris *) (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) @@ -10,19 +10,13 @@ (* *) (* *********************************************************************) -Require Import Coqlib. -Require Import Compopts. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Op. -Require Import ValueDomain. -Require Import RTL. +Require Import Coqlib Compopts. +Require Import AST Integers Floats Values Memory Globalenvs. +Require Import Op RTL ValueDomain. -(** Value analysis for IA32 operators *) +Local Transparent Archi.ptr64. + +(** Value analysis for x86_64 operators *) Definition eval_static_condition (cond: condition) (vl: list aval): abool := match cond, vl with @@ -30,6 +24,10 @@ Definition eval_static_condition (cond: condition) (vl: list aval): abool := | 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 @@ -39,26 +37,45 @@ Definition eval_static_condition (cond: condition) (vl: list aval): abool := | _, _ => Bnone end. -Definition eval_static_addressing (addr: addressing) (vl: list aval): aval := +Definition eval_static_addressing_32 (addr: addressing) (vl: list aval): aval := match addr, vl with - | Aindexed n, v1::nil => add v1 (I n) - | Aindexed2 n, v1::v2::nil => add (add v1 v2) (I n) - | Ascaled sc ofs, v1::nil => add (mul v1 (I sc)) (I ofs) - | Aindexed2scaled sc ofs, v1::v2::nil => add v1 (add (mul v2 (I sc)) (I ofs)) + | 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 sc)) + | 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 Int.zero) + | 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 @@ -89,7 +106,36 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | 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 addr vl + | 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) + | 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) + | 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 @@ -108,9 +154,10 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Ofloatofint, v1::nil => floatofint v1 | Ointofsingle, v1::nil => intofsingle v1 | Osingleofint, v1::nil => singleofint v1 - | Omakelong, v1::v2::nil => longofwords v1 v2 - | Olowlong, v1::nil => loword v1 - | Ohighlong, v1::nil => hiword 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. @@ -128,8 +175,7 @@ Theorem eval_static_condition_sound: 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. + intros until aargs; intros VM. inv VM. destruct cond; auto with va. inv H0. destruct cond; simpl; eauto with va. @@ -162,23 +208,45 @@ Ltac InvHyps := | [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 Int.zero) addr vargs = Some vres -> + 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 addr; InvHyps; eauto with va. - rewrite Int.add_zero_l; auto with va. + 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 Int.zero) op vargs m = Some vres -> + 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. @@ -186,7 +254,8 @@ Proof. destruct op; InvHyps; eauto with va. destruct (propagate_float_constants tt); constructor. destruct (propagate_float_constants tt); constructor. - eapply eval_static_addressing_sound; eauto. + 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. diff --git a/ia32/extractionMachdep.v b/ia32/extractionMachdep.v index 3c6ee2e0..8b395579 100644 --- a/ia32/extractionMachdep.v +++ b/ia32/extractionMachdep.v @@ -10,11 +10,22 @@ (* *) (* *********************************************************************) -(* Additional extraction directives specific to the IA32 port *) +(* Additional extraction directives specific to the x86-64 port *) -Require SelectOp. +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". + -- cgit