aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rwxr-xr-xconfigure39
-rw-r--r--ia32/Archi.v19
-rw-r--r--ia32/Asm.v543
-rw-r--r--ia32/Asmexpand.ml367
-rw-r--r--ia32/Asmgen.v350
-rw-r--r--ia32/Asmgenproof.v116
-rw-r--r--ia32/Asmgenproof1.v751
-rw-r--r--ia32/CBuiltins.ml9
-rw-r--r--ia32/CombineOp.v49
-rw-r--r--ia32/CombineOpproof.v48
-rw-r--r--ia32/ConstpropOp.vp226
-rw-r--r--ia32/ConstpropOpproof.v499
-rw-r--r--ia32/Conventions1.v331
-rw-r--r--ia32/Machregs.v111
-rw-r--r--ia32/NeedOp.v116
-rw-r--r--ia32/Op.v895
-rw-r--r--ia32/PrintOp.ml70
-rw-r--r--ia32/SelectLong.vp365
-rw-r--r--ia32/SelectLongproof.v304
-rw-r--r--ia32/SelectOp.vp79
-rw-r--r--ia32/SelectOpproof.v153
-rw-r--r--ia32/Stacklayout.v70
-rw-r--r--ia32/TargetPrinter.ml508
-rw-r--r--ia32/ValueAOp.v133
-rw-r--r--ia32/extractionMachdep.v15
-rw-r--r--runtime/Makefile13
-rw-r--r--runtime/x86_64/i64_dtou.S56
-rw-r--r--runtime/x86_64/i64_utod.S56
-rw-r--r--runtime/x86_64/i64_utof.S56
-rw-r--r--runtime/x86_64/sysdeps.h75
-rw-r--r--runtime/x86_64/vararg.S148
31 files changed, 4945 insertions, 1625 deletions
diff --git a/configure b/configure
index c15ce3eb..ccdf6c27 100755
--- a/configure
+++ b/configure
@@ -40,6 +40,7 @@ Supported targets:
ia32-bsd (x86 32 bits, BSD)
ia32-macosx (x86 32 bits, MacOS X)
ia32-cygwin (x86 32 bits, Cygwin environment under Windows)
+ x86_64-linux (x86 64 bits, Linux)
manual (edit configuration file by hand)
For PowerPC targets, the "ppc-" prefix can be refined into:
@@ -118,7 +119,9 @@ case "$target" in
armebv7m-*)
arch="arm"; model="armv7m"; endianness="big";;
ia32-*)
- arch="ia32"; model="sse2"; endianness="little";;
+ arch="ia32"; model="32sse2"; endianness="little";;
+ x86_64-*)
+ arch="ia32"; model="64"; endianness="little";;
powerpc-*|ppc-*)
arch="powerpc"; model="ppc32"; endianness="big";;
powerpc64-*|ppc64-*)
@@ -239,9 +242,9 @@ fi
#
-# IA32 Target Configuration
+# IA32 (32 bits) Target Configuration
#
-if test "$arch" = "ia32"; then
+if test "$arch" = "ia32" -a "$model" != "64"; then
case "$target" in
bsd)
@@ -318,6 +321,33 @@ if test "$arch" = "ia32"; then
fi
#
+# IA32 (64 bits) Target Configuration
+#
+if test "$arch" = "ia32" -a "$model" = "64"; then
+
+ case "$target" in
+ linux)
+ abi="standard"
+ casm="${toolprefix}gcc"
+ casm_options="-m64 -c"
+ cc="${toolprefix}gcc -m64"
+ clinker="${toolprefix}gcc"
+ clinker_options="-m64"
+ cprepro="${toolprefix}gcc"
+ cprepro_options="-std=c99 -m64 -U__GNUC__ -E"
+ libmath="-lm"
+ struct_passing="ref-callee" # wrong!
+ struct_return="ref" # to check!
+ system="linux"
+ ;;
+ *)
+ echo "Error: invalid eabi/system '$target' for architecture X86_64." 1>&2
+ echo "$usage" 1>&2
+ exit 2;;
+ esac
+fi
+
+#
# Finalize Target Configuration
#
if test -z "$casmruntime"; then casmruntime="$casm $casm_options"; fi
@@ -491,7 +521,8 @@ ARCH=
# MODEL=armv7a # for ARM
# MODEL=armv7r # for ARM
# MODEL=armv7m # for ARM
-# MODEL=sse2 # for IA32
+# MODEL=32sse2 # for IA32 in 32-bit mode
+# MODEL=64 # for IA32 in 64-bit mode
MODEL=
# Target ABI
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 or unordered, 0 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 "<bad addressing>"
let print_operation reg pp = function
| Omove, [r1] -> reg pp r1
| Ointconst n, [] -> fprintf pp "%ld" (camlint_of_coqint n)
+ | Olongconst n, [] -> fprintf pp "%LdL" (camlint64_of_coqint n)
| Ofloatconst n, [] -> fprintf pp "%.15F" (camlfloat_of_coqfloat n)
| Osingleconst n, [] -> fprintf pp "%.15Ff" (camlfloat_of_coqfloat32 n)
| Oindirectsymbol id, [] -> fprintf pp "&%s" (extern_atom id)
@@ -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 <<l %a" reg r1 reg r2
+ | Oshllimm n, [r1] -> fprintf pp "%a <<l %ld" reg r1 (camlint_of_coqint n)
+ | Oshrl, [r1;r2] -> fprintf pp "%a >>ls %a" reg r1 reg r2
+ | Oshrlimm n, [r1] -> fprintf pp "%a >>ls %ld" reg r1 (camlint_of_coqint n)
+ | 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 "<bad operator>"
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".
+
diff --git a/runtime/Makefile b/runtime/Makefile
index c01ef38d..59d2bb64 100644
--- a/runtime/Makefile
+++ b/runtime/Makefile
@@ -1,11 +1,24 @@
include ../Makefile.config
CFLAGS=-O1 -g -Wall
+
+ifeq ($(ARCH),ia32)
+ifeq ($(MODEL),64)
+ARCH=x86_64
+endif
+endif
+
+ifeq ($(ARCH),x86_64)
+OBJS=i64_dtou.o i64_utod.o i64_utof.o vararg.o
+else
OBJS=i64_dtos.o i64_dtou.o i64_sar.o i64_sdiv.o i64_shl.o \
i64_shr.o i64_smod.o i64_stod.o i64_stof.o \
i64_udivmod.o i64_udiv.o i64_umod.o i64_utod.o i64_utof.o \
vararg.o
+endif
+
LIB=libcompcert.a
+
INCLUDES=include/float.h include/stdarg.h include/stdbool.h \
include/stddef.h include/varargs.h include/stdalign.h \
include/stdnoreturn.h
diff --git a/runtime/x86_64/i64_dtou.S b/runtime/x86_64/i64_dtou.S
new file mode 100644
index 00000000..e455ea6f
--- /dev/null
+++ b/runtime/x86_64/i64_dtou.S
@@ -0,0 +1,56 @@
+// *****************************************************************
+//
+// The Compcert verified compiler
+//
+// Xavier Leroy, INRIA Paris
+//
+// Copyright (c) 2016 Institut National de Recherche en Informatique et
+// en Automatique.
+//
+// Redistribution and use in source and binary forms, with or without
+// modification, are permitted provided that the following conditions are met:
+// * Redistributions of source code must retain the above copyright
+// notice, this list of conditions and the following disclaimer.
+// * Redistributions in binary form must reproduce the above copyright
+// notice, this list of conditions and the following disclaimer in the
+// documentation and/or other materials provided with the distribution.
+// * Neither the name of the <organization> nor the
+// names of its contributors may be used to endorse or promote products
+// derived from this software without specific prior written permission.
+//
+// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+// "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+// LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+// A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT
+// HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+// EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+// PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+// PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+// LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+//
+// *********************************************************************
+
+// Helper functions for 64-bit integer arithmetic. x86_64 version.
+
+#include "sysdeps.h"
+
+// Conversion float -> unsigned long
+
+FUNCTION(__i64_dtou)
+ ucomisd .LC1(%rip), %xmm0
+ jnb 1f
+ cvttsd2siq %xmm0, %rax
+ ret
+1: subsd .LC1(%rip), %xmm0
+ cvttsd2siq %xmm0, %rax
+ addq .LC2(%rip), %rax
+ ret
+
+ .p2align 3
+.LC1: .quad 0x43e0000000000000 // 2^63 in double precision
+.LC2: .quad 0x8000000000000000 // 2^63 as an integer
+
+ENDFUNCTION(__i64_dtou)
+
diff --git a/runtime/x86_64/i64_utod.S b/runtime/x86_64/i64_utod.S
new file mode 100644
index 00000000..96b77a64
--- /dev/null
+++ b/runtime/x86_64/i64_utod.S
@@ -0,0 +1,56 @@
+// *****************************************************************
+//
+// The Compcert verified compiler
+//
+// Xavier Leroy, INRIA Paris
+//
+// Copyright (c) 2016 Institut National de Recherche en Informatique et
+// en Automatique.
+//
+// Redistribution and use in source and binary forms, with or without
+// modification, are permitted provided that the following conditions are met:
+// * Redistributions of source code must retain the above copyright
+// notice, this list of conditions and the following disclaimer.
+// * Redistributions in binary form must reproduce the above copyright
+// notice, this list of conditions and the following disclaimer in the
+// documentation and/or other materials provided with the distribution.
+// * Neither the name of the <organization> nor the
+// names of its contributors may be used to endorse or promote products
+// derived from this software without specific prior written permission.
+//
+// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+// "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+// LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+// A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT
+// HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+// EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+// PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+// PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+// LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+//
+// *********************************************************************
+
+// Helper functions for 64-bit integer arithmetic. x86_64 version.
+
+#include "sysdeps.h"
+
+// Conversion unsigned long -> double-precision float
+
+FUNCTION(__i64_utod)
+ testq %rdi, %rdi
+ js 1f
+ pxor %xmm0, %xmm0 // if < 2^63,
+ cvtsi2sdq %rdi, %xmm0 // convert as if signed
+ ret
+1: // if >= 2^63, use round-to-odd trick
+ movq %rdi, %rax
+ shrq %rax
+ andq $1, %rdi
+ orq %rdi, %rax // (arg >> 1) | (arg & 1)
+ pxor %xmm0, %xmm0
+ cvtsi2sdq %rax, %xmm0 // convert as if signed
+ addsd %xmm0, %xmm0 // multiply result by 2.0
+ ret
+ENDFUNCTION(__i64_utod)
diff --git a/runtime/x86_64/i64_utof.S b/runtime/x86_64/i64_utof.S
new file mode 100644
index 00000000..d0935341
--- /dev/null
+++ b/runtime/x86_64/i64_utof.S
@@ -0,0 +1,56 @@
+// *****************************************************************
+//
+// The Compcert verified compiler
+//
+// Xavier Leroy, INRIA Paris
+//
+// Copyright (c) 2016 Institut National de Recherche en Informatique et
+// en Automatique.
+//
+// Redistribution and use in source and binary forms, with or without
+// modification, are permitted provided that the following conditions are met:
+// * Redistributions of source code must retain the above copyright
+// notice, this list of conditions and the following disclaimer.
+// * Redistributions in binary form must reproduce the above copyright
+// notice, this list of conditions and the following disclaimer in the
+// documentation and/or other materials provided with the distribution.
+// * Neither the name of the <organization> nor the
+// names of its contributors may be used to endorse or promote products
+// derived from this software without specific prior written permission.
+//
+// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+// "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+// LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+// A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT
+// HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+// EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+// PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+// PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+// LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+//
+// *********************************************************************
+
+// Helper functions for 64-bit integer arithmetic. x86_64 version.
+
+#include "sysdeps.h"
+
+// Conversion unsigned long -> single-precision float
+
+FUNCTION(__i64_utof)
+ testq %rdi, %rdi
+ js 1f
+ pxor %xmm0, %xmm0 // if < 2^63,
+ cvtsi2ssq %rdi, %xmm0 // convert as if signed
+ ret
+1: // if >= 2^63, use round-to-odd trick
+ movq %rdi, %rax
+ shrq %rax
+ andq $1, %rdi
+ orq %rdi, %rax // (arg >> 1) | (arg & 1)
+ pxor %xmm0, %xmm0
+ cvtsi2ssq %rax, %xmm0 // convert as if signed
+ addss %xmm0, %xmm0 // multiply result by 2.0
+ ret
+ENDFUNCTION(__i64_utof)
diff --git a/runtime/x86_64/sysdeps.h b/runtime/x86_64/sysdeps.h
new file mode 100644
index 00000000..e9d456af
--- /dev/null
+++ b/runtime/x86_64/sysdeps.h
@@ -0,0 +1,75 @@
+// *****************************************************************
+//
+// The Compcert verified compiler
+//
+// Xavier Leroy, INRIA Paris
+//
+// Copyright (c) 2016 Institut National de Recherche en Informatique et
+// en Automatique.
+//
+// Redistribution and use in source and binary forms, with or without
+// modification, are permitted provided that the following conditions are met:
+// * Redistributions of source code must retain the above copyright
+// notice, this list of conditions and the following disclaimer.
+// * Redistributions in binary form must reproduce the above copyright
+// notice, this list of conditions and the following disclaimer in the
+// documentation and/or other materials provided with the distribution.
+// * Neither the name of the <organization> nor the
+// names of its contributors may be used to endorse or promote products
+// derived from this software without specific prior written permission.
+//
+// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+// "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+// LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+// A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT
+// HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+// EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+// PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+// PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+// LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+//
+// *********************************************************************
+
+// System dependencies
+
+#if defined(SYS_linux) || defined(SYS_bsd)
+
+#define GLOB(x) x
+#define FUNCTION(f) \
+ .text; \
+ .globl f; \
+ .align 16; \
+f:
+
+#define ENDFUNCTION(f) \
+ .type f, @function; .size f, . - f
+
+#endif
+
+#if defined(SYS_macosx)
+
+#define GLOB(x) _##x
+#define FUNCTION(f) \
+ .text; \
+ .globl _##f; \
+ .align 4; \
+_##f:
+
+#define ENDFUNCTION(f)
+
+#endif
+
+#if defined(SYS_cygwin)
+
+#define GLOB(x) _##x
+#define FUNCTION(f) \
+ .text; \
+ .globl _##f; \
+ .align 16; \
+_##f:
+
+#define ENDFUNCTION(f)
+
+#endif
diff --git a/runtime/x86_64/vararg.S b/runtime/x86_64/vararg.S
new file mode 100644
index 00000000..3e645474
--- /dev/null
+++ b/runtime/x86_64/vararg.S
@@ -0,0 +1,148 @@
+// *****************************************************************
+//
+// The Compcert verified compiler
+//
+// Xavier Leroy, INRIA Paris
+//
+// Copyright (c) 2016 Institut National de Recherche en Informatique et
+// en Automatique.
+//
+// Redistribution and use in source and binary forms, with or without
+// modification, are permitted provided that the following conditions are met:
+// * Redistributions of source code must retain the above copyright
+// notice, this list of conditions and the following disclaimer.
+// * Redistributions in binary form must reproduce the above copyright
+// notice, this list of conditions and the following disclaimer in the
+// documentation and/or other materials provided with the distribution.
+// * Neither the name of the <organization> nor the
+// names of its contributors may be used to endorse or promote products
+// derived from this software without specific prior written permission.
+//
+// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+// "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+// LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+// A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT
+// HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+// EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+// PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+// PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+// LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+//
+// *********************************************************************
+
+// Helper functions for variadic functions <stdarg.h>. x86_64 version.
+
+// typedef struct {
+// unsigned int gp_offset;
+// unsigned int fp_offset;
+// void *overflow_arg_area;
+// void *reg_save_area;
+// } va_list[1];
+
+// The va_start macro initializes the structure as follows:
+// - reg_save_area: The element points to the start of the register save area.
+// - overflow_arg_area: This pointer is used to fetch arguments passed on
+// the stack. It is initialized with the address of the first argument
+// passed on the stack, if any, and then always updated to point to the
+// start of the next argument on the stack.
+// - gp_offset: The element holds the offset in bytes from reg_save_area
+// to the place where the next available general purpose argument
+// register is saved. In case all argument registers have been
+// exhausted, it is set to the value 48 (6 * 8).
+// - fp_offset: The element holds the offset in bytes from reg_save_area
+// to the place where the next available floating point argument
+// register is saved. In case all argument registers have been
+// exhausted, it is set to the value 176 (6 * 8 + 8 * 16).
+
+// unsigned int __compcert_va_int32(va_list ap);
+// unsigned long long __compcert_va_int64(va_list ap);
+// double __compcert_va_float64(va_list ap);
+
+#include "sysdeps.h"
+
+FUNCTION(__compcert_va_int32)
+ movl 0(%rdi), %edx // edx = gp_offset
+ cmpl $48, %edx
+ jae 1f
+ // next argument is in gp reg area
+ movq 16(%rdi), %rsi // rsi = reg_save_area
+ movl 0(%rsi, %rdx, 1), %eax // next integer argument
+ addl $8, %edx
+ movl %edx, 0(%rdi) // increment gp_offset by 8
+ ret
+ // next argument is in overflow arg area
+1: movq 8(%rdi), %rsi // rsi = overflow_arg_area
+ movq 0(%rsi), %rax // next integer argument
+ addq $8, %rsi
+ movq %rsi, 8(%rdi) // increment overflow_arg_area by 8
+ ret
+ENDFUNCTION(__compcert_va_int32)
+
+FUNCTION(__compcert_va_int64)
+ movl 0(%rdi), %edx // edx = gp_offset
+ cmpl $48, %edx
+ jae 1f
+ // next argument is in gp reg area
+ movq 16(%rdi), %rsi // rsi = reg_save_area
+ movq 0(%rsi, %rdx, 1), %rax // next integer argument
+ addl $8, %edx
+ movl %edx, 0(%rdi) // increment gp_offset by 8
+ ret
+ // next argument is in overflow arg area
+1: movq 8(%rdi), %rsi // rsi = overflow_arg_area
+ movq 0(%rsi), %rax // next integer argument
+ addq $8, %rsi
+ movq %rsi, 8(%rdi) // increment overflow_arg_area by 8
+ ret
+ENDFUNCTION(__compcert_va_int64)
+
+FUNCTION(__compcert_va_float64)
+ movl 4(%rdi), %edx // edx = fp_offset
+ cmpl $176, %edx
+ jae 1f
+ // next argument is in fp reg area
+ movq 16(%rdi), %rsi // rsi = reg_save_area
+ movsd 0(%rsi, %rdx, 1), %xmm0 // next floating-point argument
+ addl $16, %edx
+ movl %edx, 4(%rdi) // increment fp_offset by 16
+ ret
+ // next argument is in overflow arg area
+1: movq 8(%rdi), %rsi // rsi = overflow_arg_area
+ movsd 0(%rsi), %xmm0 // next floating-point argument
+ addq $8, %rsi
+ movq %rsi, 8(%rdi) // increment overflow_arg_area by 8
+ ret
+ENDFUNCTION(__compcert_va_float64)
+
+FUNCTION(__compcert_va_composite)
+ jmp __compcert_va_int64 // by-ref convention, FIXME
+ENDFUNCTION(__compcert_va_composite)
+
+// Save integer and FP registers at beginning of vararg function
+// r10 points to register save area
+// al contains number of FP arguments passed in registers
+// The register save area has the following shape:
+// 0, 8, ..., 40 -> 6 x 8-byte slots for saving rdi, rsi, rdx, rcx, r8, r9
+// 48, 64, ... 160 -> 8 x 16-byte slots for saving xmm0...xmm7
+
+FUNCTION(__compcert_va_saveregs)
+ movq %rdi, 0(%r10)
+ movq %rsi, 8(%r10)
+ movq %rdx, 16(%r10)
+ movq %rcx, 24(%r10)
+ movq %r8, 32(%r10)
+ movq %r9, 40(%r10)
+ testb %al, %al
+ je 1f
+ movaps %xmm0, 48(%r10)
+ movaps %xmm1, 64(%r10)
+ movaps %xmm2, 80(%r10)
+ movaps %xmm3, 96(%r10)
+ movaps %xmm4, 112(%r10)
+ movaps %xmm5, 128(%r10)
+ movaps %xmm6, 144(%r10)
+ movaps %xmm7, 160(%r10)
+1: ret
+ENDFUNCTION(__compcert_va_saveregs)
generated by cgit (git 2.34.1) at 2024-06-02 20:33:23 +0000