diff options
| author | David Monniaux <david.monniaux@univ-grenoble-alpes.fr> | 2020-04-20 14:06:21 +0200 |
|---|---|---|
| committer | David Monniaux <david.monniaux@univ-grenoble-alpes.fr> | 2020-04-20 14:06:21 +0200 |
| commit | 168393089024b5f926836cb813fddf14e6b6e4d4 (patch) | |
| tree | 5d018198dc26be847544f162b87ad3dcecbab479 /mppa_k1c | |
| parent | 633b72565b022f159526338b5bbb9fcac86dfd2b (diff) | |
| parent | b3431b1d9ee5121883d307cff0b62b7e53369891 (diff) | |
| download | compcert-kvx-168393089024b5f926836cb813fddf14e6b6e4d4.tar.gz compcert-kvx-168393089024b5f926836cb813fddf14e6b6e4d4.zip | |
Merge remote-tracking branch 'origin/mppa-work' into mppa-fast-div
(unfinished)
Diffstat (limited to 'mppa_k1c')
56 files changed, 8851 insertions, 6790 deletions
diff --git a/mppa_k1c/Archi.v b/mppa_k1c/Archi.v index bbe66c5b..69b32c7c 100644 --- a/mppa_k1c/Archi.v +++ b/mppa_k1c/Archi.v @@ -14,11 +14,10 @@ (* *) (* *********************************************************************) -(** Architecture-dependent parameters for RISC-V *) +(** Architecture-dependent parameters for MPPA K1c. Mostly copied from the Risc-V backend *) -Require Import ZArith. -Require Import Fappli_IEEE. -Require Import Fappli_IEEE_bits. +Require Import ZArith List. +Require Import Binary Bits. Definition ptr64 := true. @@ -34,6 +33,8 @@ Proof. unfold splitlong. destruct ptr64; simpl; congruence. Qed. +(** THIS IS NOT CHECKED ! NONE OF THIS ! *) + (** Section 7.3: "Except when otherwise stated, if the result of a floating-point operation is NaN, it is the canonical NaN. The canonical NaN has a positive sign and all significand bits clear @@ -41,23 +42,36 @@ Qed. We need to extend the [choose_binop_pl] functions to account for this case. *) -Program Definition default_pl_64 : bool * nan_pl 53 := - (false, iter_nat 51 _ xO xH). +Definition default_nan_64 := (false, iter_nat 51 _ xO xH). +Definition default_nan_32 := (false, iter_nat 22 _ xO xH). + +(* Always choose the first NaN argument, if any *) + +Definition choose_nan_64 (l: list (bool * positive)) : bool * positive := + match l with nil => default_nan_64 | n :: _ => n end. + +Definition choose_nan_32 (l: list (bool * positive)) : bool * positive := + match l with nil => default_nan_32 | n :: _ => n end. + +Definition fpu_returns_default_qNaN := false. -Definition choose_binop_pl_64 (s1: bool) (pl1: nan_pl 53) (s2: bool) (pl2: nan_pl 53) := - false. (**r always choose first NaN *) +Lemma choose_nan_64_idem: forall n, + choose_nan_64 (n :: n :: nil) = choose_nan_64 (n :: nil). +Proof. auto. Qed. -Program Definition default_pl_32 : bool * nan_pl 24 := - (false, iter_nat 22 _ xO xH). +Lemma choose_nan_32_idem: forall n, + choose_nan_32 (n :: n :: nil) = choose_nan_32 (n :: nil). +Proof. auto. Qed. -Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_pl 24) := - false. (**r always choose first NaN *) +Definition fma_order {A: Type} (x y z: A) := (x, z, y). +Definition fma_invalid_mul_is_nan := false. Definition float_of_single_preserves_sNaN := false. Global Opaque ptr64 big_endian splitlong - default_pl_64 choose_binop_pl_64 - default_pl_32 choose_binop_pl_32 + default_nan_64 choose_nan_64 + default_nan_32 choose_nan_32 + fma_order fma_invalid_mul_is_nan float_of_single_preserves_sNaN. (** Whether to generate position-independent code or not *) diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 1774b102..189e0c76 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -1,736 +1,753 @@ -(* *********************************************************************)
-(* *)
-(* The Compcert verified compiler *)
-(* *)
-(* Xavier Leroy, INRIA Paris-Rocquencourt *)
-(* Prashanth Mundkur, SRI International *)
-(* *)
-(* 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. *)
-(* *)
-(* The contributions by Prashanth Mundkur are reused and adapted *)
-(* under the terms of a Contributor License Agreement between *)
-(* SRI International and INRIA. *)
-(* *)
-(* *********************************************************************)
-
-(** Abstract syntax and semantics for K1c assembly language. *)
-
-Require Import Coqlib.
-Require Import Maps.
-Require Import AST.
-Require Import Integers.
-Require Import Floats.
-Require Import Values.
-Require Import ExtValues.
-Require Import Memory.
-Require Import Events.
-Require Import Globalenvs.
-Require Import Smallstep.
-Require Import Locations.
-Require Stacklayout.
-Require Import Conventions.
-Require Import Asmvliw.
-Require Import Linking.
-Require Import Errors.
-
-(** Definitions for OCaml code *)
-Definition label := positive.
-Definition preg := preg.
-
-Inductive addressing : Type :=
- | AOff (ofs: offset)
- | AReg (ro: ireg)
- | ARegXS (ro: ireg)
-.
-
-(** Syntax *)
-Inductive instruction : Type :=
- (** pseudo instructions *)
- | Pallocframe (sz: Z) (pos: ptrofs) (**r allocate new stack frame *)
- | Pfreeframe (sz: Z) (pos: ptrofs) (**r deallocate stack frame and restore previous frame *)
- | Plabel (lbl: label) (**r define a code label *)
- | Ploadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the address of a symbol *)
- | Pbuiltin: external_function -> list (builtin_arg preg)
- -> builtin_res preg -> instruction (**r built-in function (pseudo) *)
- | Psemi (**r semi colon separating bundles *)
- | Pnop (**r instruction that does nothing *)
-
- (** builtins *)
- | Pclzll (rd rs: ireg)
- | Pstsud (rd rs1 rs2: ireg)
-
- (** Control flow instructions *)
- | Pget (rd: ireg) (rs: preg) (**r get system register *)
- | Pset (rd: preg) (rs: ireg) (**r set system register *)
- | Pret (**r return *)
- | Pcall (l: label) (**r function call *)
- | Picall (rs: ireg) (**r function call on register *)
- (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *)
- | Pgoto (l: label) (**r goto *)
- | Pigoto (rs: ireg) (**r goto from register *)
- | Pj_l (l: label) (**r jump to label *)
- | Pcb (bt: btest) (r: ireg) (l: label) (**r branch based on btest *)
- | Pcbu (bt: btest) (r: ireg) (l: label) (**r branch based on btest with unsigned semantics *)
- | Pjumptable (r: ireg) (labels: list label)
-
- (* For builtins *)
- | Ploopdo (count: ireg) (loopend: label)
- | Pgetn (n: int) (dst: ireg)
- | Psetn (n: int) (src: ireg)
- | Pwfxl (n: int) (src: ireg)
- | Pwfxm (n: int) (src: ireg)
- | Pldu (dst: ireg) (addr: ireg)
- | Plbzu (dst: ireg) (addr: ireg)
- | Plhzu (dst: ireg) (addr: ireg)
- | Plwzu (dst: ireg) (addr: ireg)
- | Pawait
- | Psleep
- | Pstop
- | Pbarrier
- | Pfence
- | Pdinval
- | Pdinvall (addr: ireg)
- | Pdtouchl (addr: ireg)
- | Piinval
- | Piinvals (addr: ireg)
- | Pitouchl (addr: ireg)
- | Pdzerol (addr: ireg)
- | Pafaddd (addr: ireg) (incr_res: ireg)
- | Pafaddw (addr: ireg) (incr_res: ireg)
- | Palclrd (dst: ireg) (addr: ireg)
- | Palclrw (dst: ireg) (addr: ireg)
-
- (** Loads **)
- | Plb (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte *)
- | Plbu (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte unsigned *)
- | Plh (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word *)
- | Plhu (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word unsigned *)
- | Plw (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int32 *)
- | Plw_a (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any32 *)
- | Pld (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int64 *)
- | Pld_a (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any64 *)
- | Pfls (rd: freg) (ra: ireg) (ofs: addressing) (**r load float *)
- | Pfld (rd: freg) (ra: ireg) (ofs: addressing) (**r load 64-bit float *)
- | Plq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r load 2*64-bit *)
- | Plo (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r load 4*64-bit *)
-
- (** Stores **)
- | Psb (rs: ireg) (ra: ireg) (ofs: addressing) (**r store byte *)
- | Psh (rs: ireg) (ra: ireg) (ofs: addressing) (**r store half byte *)
- | Psw (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int32 *)
- | Psw_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any32 *)
- | Psd (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int64 *)
- | Psd_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any64 *)
- | Pfss (rs: freg) (ra: ireg) (ofs: addressing) (**r store float *)
- | Pfsd (rs: freg) (ra: ireg) (ofs: addressing) (**r store 64-bit float *)
-
- | Psq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *)
- | Pso (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *)
-
- (** Arith RR *)
- | Pmv (rd rs: ireg) (**r register move *)
- | Pnegw (rd rs: ireg) (**r negate word *)
- | Pnegl (rd rs: ireg) (**r negate long *)
- | Pcvtl2w (rd rs: ireg) (**r Convert Long to Word *)
- | Psxwd (rd rs: ireg) (**r Sign Extend Word to Double Word *)
- | Pzxwd (rd rs: ireg) (**r Zero Extend Word to Double Word *)
-
- | Pextfz (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *)
- | Pextfs (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *)
-
- | Pextfzl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *)
- | Pextfsl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *)
-
- | Pinsf (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *)
- | Pinsfl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *)
-
- | Pfabsd (rd rs: ireg) (**r float absolute double *)
- | Pfabsw (rd rs: ireg) (**r float absolute word *)
- | Pfnegd (rd rs: ireg) (**r float negate double *)
- | Pfnegw (rd rs: ireg) (**r float negate word *)
- | Pfnarrowdw (rd rs: ireg) (**r float narrow 64 -> 32 bits *)
- | Pfwidenlwd (rd rs: ireg) (**r float widen 32 -> 64 bits *)
- | Pfloatwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (32 -> 32) *)
- | Pfloatuwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (u32 -> 32) *)
- | Pfloatudrnsz (rd rs: ireg) (**r Floating Point Conversion from unsigned integer (64 bits) *)
- | Pfloatdrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (64 bits) *)
- | Pfixedwrzz (rd rs: ireg) (**r Integer conversion from floating point *)
- | Pfixeduwrzz (rd rs: ireg) (**r Integer conversion from floating point (f32 -> 32 bits unsigned *)
- | Pfixeddrzz (rd rs: ireg) (**r Integer conversion from floating point (i64 -> 64 bits) *)
- | Pfixeddrzz_i32 (rd rs: ireg) (**r Integer conversion from floating point (i32 -> f64) *)
- | Pfixedudrzz (rd rs: ireg) (**r unsigned Integer conversion from floating point (u64 -> 64 bits) *)
- | Pfixedudrzz_i32 (rd rs: ireg) (**r unsigned Integer conversion from floating point (u32 -> 64 bits) *)
-
- (** Arith RI32 *)
- | Pmake (rd: ireg) (imm: int) (**r load immediate *)
-
- (** Arith RI64 *)
- | Pmakel (rd: ireg) (imm: int64) (**r load immediate long *)
-
- (** Arith RF32 *)
- | Pmakefs (rd: ireg) (imm: float32)
-
- (** Arith RF64 *)
- | Pmakef (rd: ireg) (imm: float)
-
- (** Arith RRR *)
- | Pcompw (it: itest) (rd rs1 rs2: ireg) (**r comparison word *)
- | Pcompl (it: itest) (rd rs1 rs2: ireg) (**r comparison long *)
- | Pfcompw (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float *)
- | Pfcompl (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float64 *)
-
- | Paddw (rd rs1 rs2: ireg) (**r add word *)
- | Psubw (rd rs1 rs2: ireg) (**r sub word *)
- | Pmulw (rd rs1 rs2: ireg) (**r mul word *)
- | Pandw (rd rs1 rs2: ireg) (**r and word *)
- | Pnandw (rd rs1 rs2: ireg) (**r nand word *)
- | Porw (rd rs1 rs2: ireg) (**r or word *)
- | Pnorw (rd rs1 rs2: ireg) (**r nor word *)
- | Pxorw (rd rs1 rs2: ireg) (**r xor word *)
- | Pnxorw (rd rs1 rs2: ireg) (**r xor word *)
- | Pandnw (rd rs1 rs2: ireg) (**r andn word *)
- | Pornw (rd rs1 rs2: ireg) (**r orn word *)
- | Psraw (rd rs1 rs2: ireg) (**r shift right arithmetic word *)
- | Psrxw (rd rs1 rs2: ireg) (**r shift right arithmetic word round to 0*)
- | Psrlw (rd rs1 rs2: ireg) (**r shift right logical word *)
- | Psllw (rd rs1 rs2: ireg) (**r shift left logical word *)
- | Pmaddw (rd rs1 rs2: ireg) (**r multiply-add words *)
-
- | Paddl (rd rs1 rs2: ireg) (**r add long *)
- | Psubl (rd rs1 rs2: ireg) (**r sub long *)
- | Pandl (rd rs1 rs2: ireg) (**r and long *)
- | Pnandl (rd rs1 rs2: ireg) (**r nand long *)
- | Porl (rd rs1 rs2: ireg) (**r or long *)
- | Pnorl (rd rs1 rs2: ireg) (**r nor long *)
- | Pxorl (rd rs1 rs2: ireg) (**r xor long *)
- | Pnxorl (rd rs1 rs2: ireg) (**r nxor long *)
- | Pandnl (rd rs1 rs2: ireg) (**r andn long *)
- | Pornl (rd rs1 rs2: ireg) (**r orn long *)
- | Pmull (rd rs1 rs2: ireg) (**r mul long (low part) *)
- | Pslll (rd rs1 rs2: ireg) (**r shift left logical long *)
- | Psrll (rd rs1 rs2: ireg) (**r shift right logical long *)
- | Psral (rd rs1 rs2: ireg) (**r shift right arithmetic long *)
- | Psrxl (rd rs1 rs2: ireg) (**r shift right arithmetic long round to 0*)
- | Pmaddl (rd rs1 rs2: ireg) (**r multiply-add long *)
-
- | Pfaddd (rd rs1 rs2: ireg) (**r Float addition double *)
- | Pfaddw (rd rs1 rs2: ireg) (**r Float addition word *)
- | Pfsbfd (rd rs1 rs2: ireg) (**r Float sub double *)
- | Pfsbfw (rd rs1 rs2: ireg) (**r Float sub word *)
- | Pfmuld (rd rs1 rs2: ireg) (**r Float mul double *)
- | Pfmulw (rd rs1 rs2: ireg) (**r Float mul word *)
-
- (** Arith RRI32 *)
- | Pcompiw (it: itest) (rd rs: ireg) (imm: int) (**r comparison imm word *)
-
- | Paddiw (rd rs: ireg) (imm: int) (**r add imm word *)
- | Pmuliw (rd rs: ireg) (imm: int) (**r mul imm word *)
- | Pandiw (rd rs: ireg) (imm: int) (**r and imm word *)
- | Pnandiw (rd rs: ireg) (imm: int) (**r nand imm word *)
- | Poriw (rd rs: ireg) (imm: int) (**r or imm word *)
- | Pnoriw (rd rs: ireg) (imm: int) (**r nor imm word *)
- | Pxoriw (rd rs: ireg) (imm: int) (**r xor imm word *)
- | Pnxoriw (rd rs: ireg) (imm: int) (**r nxor imm word *)
- | Pandniw (rd rs: ireg) (imm: int) (**r andn imm word *)
- | Porniw (rd rs: ireg) (imm: int) (**r orn imm word *)
- | Psraiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word *)
- | Psrxiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*)
- | Psrliw (rd rs: ireg) (imm: int) (**r shift right logical imm word *)
- | Pslliw (rd rs: ireg) (imm: int) (**r shift left logical imm word *)
- | Proriw (rd rs: ireg) (imm: int) (**r rotate right imm word *)
- | Pmaddiw (rd rs: ireg) (imm: int) (**r multiply add imm word *)
- | Psllil (rd rs: ireg) (imm: int) (**r shift left logical immediate long *)
- | Psrxil (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*)
- | Psrlil (rd rs: ireg) (imm: int) (**r shift right logical immediate long *)
- | Psrail (rd rs: ireg) (imm: int) (**r shift right arithmetic immediate long *)
-
- (** Arith RRI64 *)
- | Pcompil (it: itest) (rd rs: ireg) (imm: int64) (**r comparison imm long *)
- | Paddil (rd rs: ireg) (imm: int64) (**r add immediate long *)
- | Pmulil (rd rs: ireg) (imm: int64) (**r add immediate long *)
- | Pandil (rd rs: ireg) (imm: int64) (**r and immediate long *)
- | Pnandil (rd rs: ireg) (imm: int64) (**r and immediate long *)
- | Poril (rd rs: ireg) (imm: int64) (**r or immediate long *)
- | Pnoril (rd rs: ireg) (imm: int64) (**r and immediate long *)
- | Pxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *)
- | Pnxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *)
- | Pandnil (rd rs: ireg) (imm: int64) (**r andn long *)
- | Pornil (rd rs: ireg) (imm: int64) (**r orn long *)
- | Pmaddil (rd rs: ireg) (imm: int64) (**r multiply add imm long *)
- | Pcmove (bt: btest) (rcond rd rs : ireg) (** conditional move *)
- | Pcmoveu (bt: btest) (rcond rd rs : ireg) (** conditional move, unsigned semantics *)
-.
-
-(** Correspondance between Asmblock and Asm *)
-
-Definition control_to_instruction (c: control) :=
- match c with
- | PExpand (Asmvliw.Pbuiltin ef args res) => Pbuiltin ef args res
- | PCtlFlow Asmvliw.Pret => Pret
- | PCtlFlow (Asmvliw.Pcall l) => Pcall l
- | PCtlFlow (Asmvliw.Picall r) => Picall r
- | PCtlFlow (Asmvliw.Pgoto l) => Pgoto l
- | PCtlFlow (Asmvliw.Pigoto l) => Pigoto l
- | PCtlFlow (Asmvliw.Pj_l l) => Pj_l l
- | PCtlFlow (Asmvliw.Pcb bt r l) => Pcb bt r l
- | PCtlFlow (Asmvliw.Pcbu bt r l) => Pcbu bt r l
- | PCtlFlow (Asmvliw.Pjumptable r label) => Pjumptable r label
- end.
-
-Definition basic_to_instruction (b: basic) :=
- match b with
- (** Special basics *)
- | Asmvliw.Pget rd rs => Pget rd rs
- | Asmvliw.Pset rd rs => Pset rd rs
- | Asmvliw.Pnop => Pnop
- | Asmvliw.Pallocframe sz pos => Pallocframe sz pos
- | Asmvliw.Pfreeframe sz pos => Pfreeframe sz pos
-
- (** PArith basics *)
- (* R *)
- | PArithR (Asmvliw.Ploadsymbol id ofs) r => Ploadsymbol r id ofs
-
- (* RR *)
- | PArithRR Asmvliw.Pmv rd rs => Pmv rd rs
- | PArithRR Asmvliw.Pnegw rd rs => Pnegw rd rs
- | PArithRR Asmvliw.Pnegl rd rs => Pnegl rd rs
- | PArithRR Asmvliw.Pcvtl2w rd rs => Pcvtl2w rd rs
- | PArithRR Asmvliw.Psxwd rd rs => Psxwd rd rs
- | PArithRR Asmvliw.Pzxwd rd rs => Pzxwd rd rs
- | PArithRR (Asmvliw.Pextfz stop start) rd rs => Pextfz rd rs stop start
- | PArithRR (Asmvliw.Pextfs stop start) rd rs => Pextfs rd rs stop start
- | PArithRR (Asmvliw.Pextfzl stop start) rd rs => Pextfzl rd rs stop start
- | PArithRR (Asmvliw.Pextfsl stop start) rd rs => Pextfsl rd rs stop start
- | PArithRR Asmvliw.Pfabsd rd rs => Pfabsd rd rs
- | PArithRR Asmvliw.Pfabsw rd rs => Pfabsw rd rs
- | PArithRR Asmvliw.Pfnegd rd rs => Pfnegd rd rs
- | PArithRR Asmvliw.Pfnegw rd rs => Pfnegw rd rs
- | PArithRR Asmvliw.Pfnarrowdw rd rs => Pfnarrowdw rd rs
- | PArithRR Asmvliw.Pfwidenlwd rd rs => Pfwidenlwd rd rs
- | PArithRR Asmvliw.Pfloatuwrnsz rd rs => Pfloatuwrnsz rd rs
- | PArithRR Asmvliw.Pfloatwrnsz rd rs => Pfloatwrnsz rd rs
- | PArithRR Asmvliw.Pfloatudrnsz rd rs => Pfloatudrnsz rd rs
- | PArithRR Asmvliw.Pfloatdrnsz rd rs => Pfloatdrnsz rd rs
- | PArithRR Asmvliw.Pfixedwrzz rd rs => Pfixedwrzz rd rs
- | PArithRR Asmvliw.Pfixeduwrzz rd rs => Pfixeduwrzz rd rs
- | PArithRR Asmvliw.Pfixeddrzz rd rs => Pfixeddrzz rd rs
- | PArithRR Asmvliw.Pfixedudrzz rd rs => Pfixedudrzz rd rs
- | PArithRR Asmvliw.Pfixeddrzz_i32 rd rs => Pfixeddrzz_i32 rd rs
- | PArithRR Asmvliw.Pfixedudrzz_i32 rd rs => Pfixedudrzz_i32 rd rs
-
- (* RI32 *)
- | PArithRI32 Asmvliw.Pmake rd imm => Pmake rd imm
-
- (* RI64 *)
- | PArithRI64 Asmvliw.Pmakel rd imm => Pmakel rd imm
-
- (* RF32 *)
- | PArithRF32 Asmvliw.Pmakefs rd imm => Pmakefs rd imm
-
- (* RF64 *)
- | PArithRF64 Asmvliw.Pmakef rd imm => Pmakef rd imm
-
- (* RRR *)
- | PArithRRR (Asmvliw.Pcompw it) rd rs1 rs2 => Pcompw it rd rs1 rs2
- | PArithRRR (Asmvliw.Pcompl it) rd rs1 rs2 => Pcompl it rd rs1 rs2
- | PArithRRR (Asmvliw.Pfcompw ft) rd rs1 rs2 => Pfcompw ft rd rs1 rs2
- | PArithRRR (Asmvliw.Pfcompl ft) rd rs1 rs2 => Pfcompl ft rd rs1 rs2
- | PArithRRR Asmvliw.Paddw rd rs1 rs2 => Paddw rd rs1 rs2
- | PArithRRR Asmvliw.Psubw rd rs1 rs2 => Psubw rd rs1 rs2
- | PArithRRR Asmvliw.Pmulw rd rs1 rs2 => Pmulw rd rs1 rs2
- | PArithRRR Asmvliw.Pandw rd rs1 rs2 => Pandw rd rs1 rs2
- | PArithRRR Asmvliw.Pnandw rd rs1 rs2 => Pnandw rd rs1 rs2
- | PArithRRR Asmvliw.Porw rd rs1 rs2 => Porw rd rs1 rs2
- | PArithRRR Asmvliw.Pnorw rd rs1 rs2 => Pnorw rd rs1 rs2
- | PArithRRR Asmvliw.Pxorw rd rs1 rs2 => Pxorw rd rs1 rs2
- | PArithRRR Asmvliw.Pnxorw rd rs1 rs2 => Pnxorw rd rs1 rs2
- | PArithRRR Asmvliw.Pandnw rd rs1 rs2 => Pandnw rd rs1 rs2
- | PArithRRR Asmvliw.Pornw rd rs1 rs2 => Pornw rd rs1 rs2
- | PArithRRR Asmvliw.Psraw rd rs1 rs2 => Psraw rd rs1 rs2
- | PArithRRR Asmvliw.Psrxw rd rs1 rs2 => Psrxw rd rs1 rs2
- | PArithRRR Asmvliw.Psrlw rd rs1 rs2 => Psrlw rd rs1 rs2
- | PArithRRR Asmvliw.Psllw rd rs1 rs2 => Psllw rd rs1 rs2
-
- | PArithRRR Asmvliw.Paddl rd rs1 rs2 => Paddl rd rs1 rs2
- | PArithRRR Asmvliw.Psubl rd rs1 rs2 => Psubl rd rs1 rs2
- | PArithRRR Asmvliw.Pandl rd rs1 rs2 => Pandl rd rs1 rs2
- | PArithRRR Asmvliw.Pnandl rd rs1 rs2 => Pnandl rd rs1 rs2
- | PArithRRR Asmvliw.Porl rd rs1 rs2 => Porl rd rs1 rs2
- | PArithRRR Asmvliw.Pnorl rd rs1 rs2 => Pnorl rd rs1 rs2
- | PArithRRR Asmvliw.Pxorl rd rs1 rs2 => Pxorl rd rs1 rs2
- | PArithRRR Asmvliw.Pnxorl rd rs1 rs2 => Pnxorl rd rs1 rs2
- | PArithRRR Asmvliw.Pandnl rd rs1 rs2 => Pandnl rd rs1 rs2
- | PArithRRR Asmvliw.Pornl rd rs1 rs2 => Pornl rd rs1 rs2
- | PArithRRR Asmvliw.Pmull rd rs1 rs2 => Pmull rd rs1 rs2
- | PArithRRR Asmvliw.Pslll rd rs1 rs2 => Pslll rd rs1 rs2
- | PArithRRR Asmvliw.Psrll rd rs1 rs2 => Psrll rd rs1 rs2
- | PArithRRR Asmvliw.Psral rd rs1 rs2 => Psral rd rs1 rs2
- | PArithRRR Asmvliw.Psrxl rd rs1 rs2 => Psrxl rd rs1 rs2
-
- | PArithRRR Asmvliw.Pfaddd rd rs1 rs2 => Pfaddd rd rs1 rs2
- | PArithRRR Asmvliw.Pfaddw rd rs1 rs2 => Pfaddw rd rs1 rs2
- | PArithRRR Asmvliw.Pfsbfd rd rs1 rs2 => Pfsbfd rd rs1 rs2
- | PArithRRR Asmvliw.Pfsbfw rd rs1 rs2 => Pfsbfw rd rs1 rs2
- | PArithRRR Asmvliw.Pfmuld rd rs1 rs2 => Pfmuld rd rs1 rs2
- | PArithRRR Asmvliw.Pfmulw rd rs1 rs2 => Pfmulw rd rs1 rs2
-
- (* RRI32 *)
- | PArithRRI32 (Asmvliw.Pcompiw it) rd rs imm => Pcompiw it rd rs imm
- | PArithRRI32 Asmvliw.Paddiw rd rs imm => Paddiw rd rs imm
- | PArithRRI32 Asmvliw.Pmuliw rd rs imm => Pmuliw rd rs imm
- | PArithRRI32 Asmvliw.Pandiw rd rs imm => Pandiw rd rs imm
- | PArithRRI32 Asmvliw.Pnandiw rd rs imm => Pnandiw rd rs imm
- | PArithRRI32 Asmvliw.Poriw rd rs imm => Poriw rd rs imm
- | PArithRRI32 Asmvliw.Pnoriw rd rs imm => Pnoriw rd rs imm
- | PArithRRI32 Asmvliw.Pxoriw rd rs imm => Pxoriw rd rs imm
- | PArithRRI32 Asmvliw.Pnxoriw rd rs imm => Pnxoriw rd rs imm
- | PArithRRI32 Asmvliw.Pandniw rd rs imm => Pandniw rd rs imm
- | PArithRRI32 Asmvliw.Porniw rd rs imm => Porniw rd rs imm
- | PArithRRI32 Asmvliw.Psraiw rd rs imm => Psraiw rd rs imm
- | PArithRRI32 Asmvliw.Psrxiw rd rs imm => Psrxiw rd rs imm
- | PArithRRI32 Asmvliw.Psrliw rd rs imm => Psrliw rd rs imm
- | PArithRRI32 Asmvliw.Pslliw rd rs imm => Pslliw rd rs imm
- | PArithRRI32 Asmvliw.Proriw rd rs imm => Proriw rd rs imm
- | PArithRRI32 Asmvliw.Psllil rd rs imm => Psllil rd rs imm
- | PArithRRI32 Asmvliw.Psrlil rd rs imm => Psrlil rd rs imm
- | PArithRRI32 Asmvliw.Psrxil rd rs imm => Psrxil rd rs imm
- | PArithRRI32 Asmvliw.Psrail rd rs imm => Psrail rd rs imm
-
- (* RRI64 *)
- | PArithRRI64 (Asmvliw.Pcompil it) rd rs imm => Pcompil it rd rs imm
- | PArithRRI64 Asmvliw.Paddil rd rs imm => Paddil rd rs imm
- | PArithRRI64 Asmvliw.Pmulil rd rs imm => Pmulil rd rs imm
- | PArithRRI64 Asmvliw.Pandil rd rs imm => Pandil rd rs imm
- | PArithRRI64 Asmvliw.Pnandil rd rs imm => Pnandil rd rs imm
- | PArithRRI64 Asmvliw.Poril rd rs imm => Poril rd rs imm
- | PArithRRI64 Asmvliw.Pnoril rd rs imm => Pnoril rd rs imm
- | PArithRRI64 Asmvliw.Pxoril rd rs imm => Pxoril rd rs imm
- | PArithRRI64 Asmvliw.Pnxoril rd rs imm => Pnxoril rd rs imm
- | PArithRRI64 Asmvliw.Pandnil rd rs imm => Pandnil rd rs imm
- | PArithRRI64 Asmvliw.Pornil rd rs imm => Pornil rd rs imm
-
- (** ARRR *)
- | PArithARRR Asmvliw.Pmaddw rd rs1 rs2 => Pmaddw rd rs1 rs2
- | PArithARRR Asmvliw.Pmaddl rd rs1 rs2 => Pmaddl rd rs1 rs2
- | PArithARRR (Asmvliw.Pcmove cond) rd rs1 rs2=> Pcmove cond rd rs1 rs2
- | PArithARRR (Asmvliw.Pcmoveu cond) rd rs1 rs2=> Pcmoveu cond rd rs1 rs2
-
- (** ARR *)
- | PArithARR (Asmvliw.Pinsf stop start) rd rs => Pinsf rd rs stop start
- | PArithARR (Asmvliw.Pinsfl stop start) rd rs => Pinsfl rd rs stop start
-
- (** ARRI32 *)
- | PArithARRI32 Asmvliw.Pmaddiw rd rs1 imm => Pmaddiw rd rs1 imm
-
- (** ARRI64 *)
- | PArithARRI64 Asmvliw.Pmaddil rd rs1 imm => Pmaddil rd rs1 imm
-
- (** Load *)
- | PLoadRRO Asmvliw.Plb rd ra ofs => Plb rd ra (AOff ofs)
- | PLoadRRO Asmvliw.Plbu rd ra ofs => Plbu rd ra (AOff ofs)
- | PLoadRRO Asmvliw.Plh rd ra ofs => Plh rd ra (AOff ofs)
- | PLoadRRO Asmvliw.Plhu rd ra ofs => Plhu rd ra (AOff ofs)
- | PLoadRRO Asmvliw.Plw rd ra ofs => Plw rd ra (AOff ofs)
- | PLoadRRO Asmvliw.Plw_a rd ra ofs => Plw_a rd ra (AOff ofs)
- | PLoadRRO Asmvliw.Pld rd ra ofs => Pld rd ra (AOff ofs)
- | PLoadRRO Asmvliw.Pld_a rd ra ofs => Pld_a rd ra (AOff ofs)
- | PLoadRRO Asmvliw.Pfls rd ra ofs => Pfls rd ra (AOff ofs)
- | PLoadRRO Asmvliw.Pfld rd ra ofs => Pfld rd ra (AOff ofs)
-
- | PLoadQRRO qrs ra ofs => Plq qrs ra (AOff ofs)
- | PLoadORRO qrs ra ofs => Plo qrs ra (AOff ofs)
-
- | PLoadRRR Asmvliw.Plb rd ra ro => Plb rd ra (AReg ro)
- | PLoadRRR Asmvliw.Plbu rd ra ro => Plbu rd ra (AReg ro)
- | PLoadRRR Asmvliw.Plh rd ra ro => Plh rd ra (AReg ro)
- | PLoadRRR Asmvliw.Plhu rd ra ro => Plhu rd ra (AReg ro)
- | PLoadRRR Asmvliw.Plw rd ra ro => Plw rd ra (AReg ro)
- | PLoadRRR Asmvliw.Plw_a rd ra ro => Plw_a rd ra (AReg ro)
- | PLoadRRR Asmvliw.Pld rd ra ro => Pld rd ra (AReg ro)
- | PLoadRRR Asmvliw.Pld_a rd ra ro => Pld_a rd ra (AReg ro)
- | PLoadRRR Asmvliw.Pfls rd ra ro => Pfls rd ra (AReg ro)
- | PLoadRRR Asmvliw.Pfld rd ra ro => Pfld rd ra (AReg ro)
-
- | PLoadRRRXS Asmvliw.Plb rd ra ro => Plb rd ra (ARegXS ro)
- | PLoadRRRXS Asmvliw.Plbu rd ra ro => Plbu rd ra (ARegXS ro)
- | PLoadRRRXS Asmvliw.Plh rd ra ro => Plh rd ra (ARegXS ro)
- | PLoadRRRXS Asmvliw.Plhu rd ra ro => Plhu rd ra (ARegXS ro)
- | PLoadRRRXS Asmvliw.Plw rd ra ro => Plw rd ra (ARegXS ro)
- | PLoadRRRXS Asmvliw.Plw_a rd ra ro => Plw_a rd ra (ARegXS ro)
- | PLoadRRRXS Asmvliw.Pld rd ra ro => Pld rd ra (ARegXS ro)
- | PLoadRRRXS Asmvliw.Pld_a rd ra ro => Pld_a rd ra (ARegXS ro)
- | PLoadRRRXS Asmvliw.Pfls rd ra ro => Pfls rd ra (ARegXS ro)
- | PLoadRRRXS Asmvliw.Pfld rd ra ro => Pfld rd ra (ARegXS ro)
-
- (** Store *)
- | PStoreRRO Asmvliw.Psb rd ra ofs => Psb rd ra (AOff ofs)
- | PStoreRRO Asmvliw.Psh rd ra ofs => Psh rd ra (AOff ofs)
- | PStoreRRO Asmvliw.Psw rd ra ofs => Psw rd ra (AOff ofs)
- | PStoreRRO Asmvliw.Psw_a rd ra ofs => Psw_a rd ra (AOff ofs)
- | PStoreRRO Asmvliw.Psd rd ra ofs => Psd rd ra (AOff ofs)
- | PStoreRRO Asmvliw.Psd_a rd ra ofs => Psd_a rd ra (AOff ofs)
- | PStoreRRO Asmvliw.Pfss rd ra ofs => Pfss rd ra (AOff ofs)
- | PStoreRRO Asmvliw.Pfsd rd ra ofs => Pfsd rd ra (AOff ofs)
-
- | PStoreRRR Asmvliw.Psb rd ra ro => Psb rd ra (AReg ro)
- | PStoreRRR Asmvliw.Psh rd ra ro => Psh rd ra (AReg ro)
- | PStoreRRR Asmvliw.Psw rd ra ro => Psw rd ra (AReg ro)
- | PStoreRRR Asmvliw.Psw_a rd ra ro => Psw_a rd ra (AReg ro)
- | PStoreRRR Asmvliw.Psd rd ra ro => Psd rd ra (AReg ro)
- | PStoreRRR Asmvliw.Psd_a rd ra ro => Psd_a rd ra (AReg ro)
- | PStoreRRR Asmvliw.Pfss rd ra ro => Pfss rd ra (AReg ro)
- | PStoreRRR Asmvliw.Pfsd rd ra ro => Pfsd rd ra (AReg ro)
-
- | PStoreRRRXS Asmvliw.Psb rd ra ro => Psb rd ra (ARegXS ro)
- | PStoreRRRXS Asmvliw.Psh rd ra ro => Psh rd ra (ARegXS ro)
- | PStoreRRRXS Asmvliw.Psw rd ra ro => Psw rd ra (ARegXS ro)
- | PStoreRRRXS Asmvliw.Psw_a rd ra ro => Psw_a rd ra (ARegXS ro)
- | PStoreRRRXS Asmvliw.Psd rd ra ro => Psd rd ra (ARegXS ro)
- | PStoreRRRXS Asmvliw.Psd_a rd ra ro => Psd_a rd ra (ARegXS ro)
- | PStoreRRRXS Asmvliw.Pfss rd ra ro => Pfss rd ra (ARegXS ro)
- | PStoreRRRXS Asmvliw.Pfsd rd ra ro => Pfsd rd ra (ARegXS ro)
-
- | PStoreQRRO qrs ra ofs => Psq qrs ra (AOff ofs)
- | PStoreORRO qrs ra ofs => Pso qrs ra (AOff ofs)
- end.
-
-Section RELSEM.
-
-Definition code := list instruction.
-
-Fixpoint unfold_label (ll: list label) :=
- match ll with
- | nil => nil
- | l :: ll => Plabel l :: unfold_label ll
- end.
-
-Fixpoint unfold_body (lb: list basic) :=
- match lb with
- | nil => nil
- | b :: lb => basic_to_instruction b :: unfold_body lb
- end.
-
-Definition unfold_exit (oc: option control) :=
- match oc with
- | None => nil
- | Some c => control_to_instruction c :: nil
- end.
-
-Definition unfold_bblock (b: bblock) := unfold_label (header b) ++
- (match (body b), (exit b) with
- | (((Asmvliw.Pfreeframe _ _ | Asmvliw.Pallocframe _ _)::nil) as bo), None =>
- unfold_body bo
- | bo, ex => unfold_body bo ++ unfold_exit ex ++ Psemi :: nil
- end).
-
-Fixpoint unfold (lb: bblocks) :=
- match lb with
- | nil => nil
- | b :: lb => (unfold_bblock b) ++ unfold lb
- end.
-
-Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks; fn_code: code;
- correct: unfold fn_blocks = fn_code }.
-
-Definition fundef := AST.fundef function.
-Definition program := AST.program fundef unit.
-Definition genv := Genv.t fundef unit.
-
-Definition function_proj (f: function) := Asmvliw.mkfunction (fn_sig f) (fn_blocks f).
-
-(*
-Definition fundef_proj (fu: fundef) : Asmblock.fundef := transf_fundef function_proj fu.
-
-Definition program_proj (p: program) : Asmblock.program := transform_program fundef_proj p.
- *)
-
-Definition fundef_proj (fu: fundef) : Asmvliw.fundef :=
- match fu with
- | Internal f => Internal (function_proj f)
- | External ef => External ef
- end.
-
-Definition globdef_proj (gd: globdef fundef unit) : globdef Asmvliw.fundef unit :=
- match gd with
- | Gfun f => Gfun (fundef_proj f)
- | Gvar gu => Gvar gu
- end.
-
-Program Definition genv_trans (ge: genv) : Asmvliw.genv :=
- {| Genv.genv_public := Genv.genv_public ge;
- Genv.genv_symb := Genv.genv_symb ge;
- Genv.genv_defs := PTree.map1 globdef_proj (Genv.genv_defs ge);
- Genv.genv_next := Genv.genv_next ge |}.
-Next Obligation.
- destruct ge. simpl in *. eauto.
-Qed. Next Obligation.
- destruct ge; simpl in *.
- rewrite PTree.gmap1 in H.
- destruct (genv_defs ! b) eqn:GEN.
- - eauto.
- - discriminate.
-Qed. Next Obligation.
- destruct ge; simpl in *.
- eauto.
-Qed.
-
-Fixpoint prog_defs_proj (l: list (ident * globdef fundef unit))
- : list (ident * globdef Asmvliw.fundef unit) :=
- match l with
- | nil => nil
- | (i, gd) :: l => (i, globdef_proj gd) :: prog_defs_proj l
- end.
-
-Definition program_proj (p: program) : Asmvliw.program :=
- {| prog_defs := prog_defs_proj (prog_defs p);
- prog_public := prog_public p;
- prog_main := prog_main p
- |}.
-
-End RELSEM.
-
-Definition semantics (p: program) := Asmvliw.semantics (program_proj p).
-
-(** Determinacy of the [Asm] semantics. *)
-
-Lemma semantics_determinate: forall p, determinate (semantics p).
-Proof.
- intros. apply semantics_determinate.
-Qed.
-
-(** transf_program *)
-
-Program Definition transf_function (f: Asmvliw.function) : function :=
- {| fn_sig := Asmvliw.fn_sig f; fn_blocks := Asmvliw.fn_blocks f;
- fn_code := unfold (Asmvliw.fn_blocks f) |}.
-
-Lemma transf_function_proj: forall f, function_proj (transf_function f) = f.
-Proof.
- intros f. destruct f as [sig blks]. unfold function_proj. simpl. auto.
-Qed.
-
-Definition transf_fundef : Asmvliw.fundef -> fundef := AST.transf_fundef transf_function.
-
-Lemma transf_fundef_proj: forall f, fundef_proj (transf_fundef f) = f.
-Proof.
- intros f. destruct f as [f|e]; simpl; auto.
- rewrite transf_function_proj. auto.
-Qed.
-
-(* Definition transf_globdef (gd: globdef Asmblock.fundef unit) : globdef fundef unit :=
- match gd with
- | Gfun f => Gfun (transf_fundef f)
- | Gvar gu => Gvar gu
- end.
-
-Lemma transf_globdef_proj: forall gd, globdef_proj (transf_globdef gd) = gd.
-Proof.
- intros gd. destruct gd as [f|v]; simpl; auto.
- rewrite transf_fundef_proj; auto.
-Qed.
-
-Fixpoint transf_prog_defs (l: list (ident * globdef Asmblock.fundef unit))
- : list (ident * globdef fundef unit) :=
- match l with
- | nil => nil
- | (i, gd) :: l => (i, transf_globdef gd) :: transf_prog_defs l
- end.
-
-Lemma transf_prog_proj: forall p, prog_defs p = prog_defs_proj (transf_prog_defs (prog_defs p)).
-Proof.
- intros p. destruct p as [defs pub main]. simpl.
- induction defs; simpl; auto.
- destruct a as [i gd]. simpl.
- rewrite transf_globdef_proj.
- congruence.
-Qed.
- *)
-
-Definition transf_program : Asmvliw.program -> program := transform_program transf_fundef.
-
-Lemma program_equals {A B: Type} : forall (p1 p2: AST.program A B),
- prog_defs p1 = prog_defs p2 ->
- prog_public p1 = prog_public p2 ->
- prog_main p1 = prog_main p2 ->
- p1 = p2.
-Proof.
- intros. destruct p1. destruct p2. simpl in *. subst. auto.
-Qed.
-
-Lemma transf_program_proj: forall p, program_proj (transf_program p) = p.
-Proof.
- intros p. destruct p as [defs pub main]. unfold program_proj. simpl.
- apply program_equals; simpl; auto.
- induction defs.
- - simpl; auto.
- - simpl. rewrite IHdefs.
- destruct a as [id gd]; simpl.
- destruct gd as [f|v]; simpl; auto.
- rewrite transf_fundef_proj. auto.
-Qed.
-
-Definition match_prog (p: Asmvliw.program) (tp: program) :=
- match_program (fun _ f tf => tf = transf_fundef f) eq p tp.
-
-Lemma transf_program_match:
- forall p tp, transf_program p = tp -> match_prog p tp.
-Proof.
- intros. rewrite <- H. eapply match_transform_program; eauto.
-Qed.
-
-Lemma cons_extract {A: Type} : forall (l: list A) a b, a = b -> a::l = b::l.
-Proof.
- intros. congruence.
-Qed.
-
-(* I think it is a special case of Asmblock -> Asm. Very handy to have *)
-Lemma match_program_transf:
- forall p tp, match_prog p tp -> transf_program p = tp.
-Proof.
- intros p tp H. inversion_clear H. inv H1.
- destruct p as [defs pub main]. destruct tp as [tdefs tpub tmain]. simpl in *.
- subst. unfold transf_program. unfold transform_program. simpl.
- apply program_equals; simpl; auto.
- induction H0; simpl; auto.
- rewrite IHlist_forall2. apply cons_extract.
- destruct a1 as [ida gda]. destruct b1 as [idb gdb].
- simpl in *.
- inv H. inv H2.
- - simpl in *. subst. auto.
- - simpl in *. subst. inv H. auto.
-Qed.
-
-Section PRESERVATION.
-
-Variable prog: Asmvliw.program.
-Variable tprog: program.
-Hypothesis TRANSF: match_prog prog tprog.
-Let ge := Genv.globalenv prog.
-Let tge := Genv.globalenv tprog.
-
-Definition match_states (s1 s2: state) := s1 = s2.
-
-Lemma symbols_preserved:
- forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
-Proof (Genv.find_symbol_match TRANSF).
-
-Lemma senv_preserved:
- Senv.equiv ge tge.
-Proof (Genv.senv_match TRANSF).
-
-
-Theorem transf_program_correct:
- forward_simulation (Asmvliw.semantics prog) (semantics tprog).
-Proof.
- pose proof (match_program_transf prog tprog TRANSF) as TR.
- subst. unfold semantics. rewrite transf_program_proj.
-
- eapply forward_simulation_step with (match_states := match_states); simpl; auto.
- - intros. exists s1. split; auto. congruence.
- - intros. inv H. auto.
- - intros. exists s1'. inv H0. split; auto. congruence.
-Qed.
-
-End PRESERVATION.
+(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Prashanth Mundkur, SRI International *) +(* *) +(* 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. *) +(* *) +(* The contributions by Prashanth Mundkur are reused and adapted *) +(* under the terms of a Contributor License Agreement between *) +(* SRI International and INRIA. *) +(* *) +(* *********************************************************************) + +(** * Abstract syntax for K1c textual assembly language. + + Each emittable instruction is defined here. ';;' is also defined as an instruction. + The goal of this representation is to stay compatible with the rest of the generic backend of CompCert + We define [unfold : list bblock -> list instruction] + An Asm function is then defined as : [fn_sig], [fn_blocks], [fn_code], and a proof of [unfold fn_blocks = fn_code] + [fn_code] has no semantic. Instead, the semantic of Asm is given by using the AsmVLIW semantic on [fn_blocks] *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import ExtValues. +Require Import Memory. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Locations. +Require Stacklayout. +Require Import Conventions. +Require Import Asmvliw. +Require Import Linking. +Require Import Errors. + +(** Definitions for OCaml code *) +Definition label := positive. +Definition preg := preg. + +Inductive addressing : Type := + | AOff (ofs: offset) + | AReg (ro: ireg) + | ARegXS (ro: ireg) +. + +(** Syntax *) +Inductive instruction : Type := + (** pseudo instructions *) + | Pallocframe (sz: Z) (pos: ptrofs) (**r allocate new stack frame *) + | Pfreeframe (sz: Z) (pos: ptrofs) (**r deallocate stack frame and restore previous frame *) + | Plabel (lbl: label) (**r define a code label *) + | Ploadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) + | Pbuiltin: external_function -> list (builtin_arg preg) + -> builtin_res preg -> instruction (**r built-in function (pseudo) *) + | Psemi (**r semi colon separating bundles *) + | Pnop (**r instruction that does nothing *) + + (** Control flow instructions *) + | Pget (rd: ireg) (rs: preg) (**r get system register *) + | Pset (rd: preg) (rs: ireg) (**r set system register *) + | Pret (**r return *) + | Pcall (l: label) (**r function call *) + | Picall (rs: ireg) (**r function call on register *) + (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *) + | Pgoto (l: label) (**r goto *) + | Pigoto (rs: ireg) (**r goto from register *) + | Pj_l (l: label) (**r jump to label *) + | Pcb (bt: btest) (r: ireg) (l: label) (**r branch based on btest *) + | Pcbu (bt: btest) (r: ireg) (l: label) (**r branch based on btest with unsigned semantics *) + | Pjumptable (r: ireg) (labels: list label) + + (* For builtins *) + | Ploopdo (count: ireg) (loopend: label) + | Pgetn (n: int) (dst: ireg) + | Psetn (n: int) (src: ireg) + | Pwfxl (n: int) (src: ireg) + | Pwfxm (n: int) (src: ireg) + | Pldu (dst: ireg) (addr: ireg) + | Plbzu (dst: ireg) (addr: ireg) + | Plhzu (dst: ireg) (addr: ireg) + | Plwzu (dst: ireg) (addr: ireg) + | Pawait + | Psleep + | Pstop + | Pbarrier + | Pfence + | Pdinval + | Pdinvall (addr: ireg) + | Pdtouchl (addr: ireg) + | Piinval + | Piinvals (addr: ireg) + | Pitouchl (addr: ireg) + | Pdzerol (addr: ireg) +(*| Pafaddd (addr: ireg) (incr_res: ireg) + | Pafaddw (addr: ireg) (incr_res: ireg) *) (* see #157 *) + | Palclrd (dst: ireg) (addr: ireg) + | Palclrw (dst: ireg) (addr: ireg) + | Pclzll (rd rs: ireg) + | Pstsud (rd rs1 rs2: ireg) + + (** Loads **) + | Plb (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte *) + | Plbu (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte unsigned *) + | Plh (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word *) + | Plhu (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word unsigned *) + | Plw (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int32 *) + | Plw_a (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any32 *) + | Pld (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int64 *) + | Pld_a (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any64 *) + | Pfls (trap: trapping_mode) (rd: freg) (ra: ireg) (ofs: addressing) (**r load float *) + | Pfld (trap: trapping_mode) (rd: freg) (ra: ireg) (ofs: addressing) (**r load 64-bit float *) + | Plq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r load 2*64-bit *) + | Plo (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r load 4*64-bit *) + + (** Stores **) + | Psb (rs: ireg) (ra: ireg) (ofs: addressing) (**r store byte *) + | Psh (rs: ireg) (ra: ireg) (ofs: addressing) (**r store half byte *) + | Psw (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int32 *) + | Psw_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any32 *) + | Psd (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int64 *) + | Psd_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any64 *) + | Pfss (rs: freg) (ra: ireg) (ofs: addressing) (**r store float *) + | Pfsd (rs: freg) (ra: ireg) (ofs: addressing) (**r store 64-bit float *) + + | Psq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *) + | Pso (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *) + + (** Arith RR *) + | Pmv (rd rs: ireg) (**r register move *) + | Pnegw (rd rs: ireg) (**r negate word *) + | Pnegl (rd rs: ireg) (**r negate long *) + | Pcvtl2w (rd rs: ireg) (**r Convert Long to Word *) + | Psxwd (rd rs: ireg) (**r Sign Extend Word to Double Word *) + | Pzxwd (rd rs: ireg) (**r Zero Extend Word to Double Word *) + + | Pextfz (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *) + | Pextfs (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *) + + | Pextfzl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *) + | Pextfsl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *) + + | Pinsf (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *) + | Pinsfl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *) + + | Pfabsd (rd rs: ireg) (**r float absolute double *) + | Pfabsw (rd rs: ireg) (**r float absolute word *) + | Pfnegd (rd rs: ireg) (**r float negate double *) + | Pfnegw (rd rs: ireg) (**r float negate word *) + | Pfnarrowdw (rd rs: ireg) (**r float narrow 64 -> 32 bits *) + | Pfwidenlwd (rd rs: ireg) (**r float widen 32 -> 64 bits *) + | Pfloatwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (32 -> 32) *) + | Pfloatuwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (u32 -> 32) *) + | Pfloatudrnsz (rd rs: ireg) (**r Floating Point Conversion from unsigned integer (64 bits) *) + | Pfloatdrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (64 bits) *) + | Pfixedwrzz (rd rs: ireg) (**r Integer conversion from floating point *) + | Pfixeduwrzz (rd rs: ireg) (**r Integer conversion from floating point (f32 -> 32 bits unsigned *) + | Pfixeddrzz (rd rs: ireg) (**r Integer conversion from floating point (i64 -> 64 bits) *) + | Pfixeddrzz_i32 (rd rs: ireg) (**r Integer conversion from floating point (i32 -> f64) *) + | Pfixedudrzz (rd rs: ireg) (**r unsigned Integer conversion from floating point (u64 -> 64 bits) *) + | Pfixedudrzz_i32 (rd rs: ireg) (**r unsigned Integer conversion from floating point (u32 -> 64 bits) *) + + (** Arith RI32 *) + | Pmake (rd: ireg) (imm: int) (**r load immediate *) + + (** Arith RI64 *) + | Pmakel (rd: ireg) (imm: int64) (**r load immediate long *) + + (** Arith RF32 *) + | Pmakefs (rd: ireg) (imm: float32) + + (** Arith RF64 *) + | Pmakef (rd: ireg) (imm: float) + + (** Arith RRR *) + | Pcompw (it: itest) (rd rs1 rs2: ireg) (**r comparison word *) + | Pcompl (it: itest) (rd rs1 rs2: ireg) (**r comparison long *) + | Pfcompw (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float *) + | Pfcompl (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float64 *) + + | Paddw (rd rs1 rs2: ireg) (**r add word *) + | Paddxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) + | Psubw (rd rs1 rs2: ireg) (**r sub word *) + | Prevsubxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) + | Pmulw (rd rs1 rs2: ireg) (**r mul word *) + | Pandw (rd rs1 rs2: ireg) (**r and word *) + | Pnandw (rd rs1 rs2: ireg) (**r nand word *) + | Porw (rd rs1 rs2: ireg) (**r or word *) + | Pnorw (rd rs1 rs2: ireg) (**r nor word *) + | Pxorw (rd rs1 rs2: ireg) (**r xor word *) + | Pnxorw (rd rs1 rs2: ireg) (**r xor word *) + | Pandnw (rd rs1 rs2: ireg) (**r andn word *) + | Pornw (rd rs1 rs2: ireg) (**r orn word *) + | Psraw (rd rs1 rs2: ireg) (**r shift right arithmetic word *) + | Psrxw (rd rs1 rs2: ireg) (**r shift right arithmetic word round to 0*) + | Psrlw (rd rs1 rs2: ireg) (**r shift right logical word *) + | Psllw (rd rs1 rs2: ireg) (**r shift left logical word *) + | Pmaddw (rd rs1 rs2: ireg) (**r multiply-add words *) + | Pmsubw (rd rs1 rs2: ireg) (**r multiply-add words *) + | Pfmaddfw (rd rs1 rs2: ireg) (**r float fused multiply-add words *) + | Pfmsubfw (rd rs1 rs2: ireg) (**r float fused multiply-subtract words *) + | Pfmaddfl (rd rs1 rs2: ireg) (**r float fused multiply-add longs *) + | Pfmsubfl (rd rs1 rs2: ireg) (**r float fused multiply-subtract longs *) + + | Paddl (rd rs1 rs2: ireg) (**r add long *) + | Paddxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r add long shift *) + | Psubl (rd rs1 rs2: ireg) (**r sub long *) + | Prevsubxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r sub long shift *) + | Pandl (rd rs1 rs2: ireg) (**r and long *) + | Pnandl (rd rs1 rs2: ireg) (**r nand long *) + | Porl (rd rs1 rs2: ireg) (**r or long *) + | Pnorl (rd rs1 rs2: ireg) (**r nor long *) + | Pxorl (rd rs1 rs2: ireg) (**r xor long *) + | Pnxorl (rd rs1 rs2: ireg) (**r nxor long *) + | Pandnl (rd rs1 rs2: ireg) (**r andn long *) + | Pornl (rd rs1 rs2: ireg) (**r orn long *) + | Pmull (rd rs1 rs2: ireg) (**r mul long (low part) *) + | Pslll (rd rs1 rs2: ireg) (**r shift left logical long *) + | Psrll (rd rs1 rs2: ireg) (**r shift right logical long *) + | Psral (rd rs1 rs2: ireg) (**r shift right arithmetic long *) + | Psrxl (rd rs1 rs2: ireg) (**r shift right arithmetic long round to 0*) + | Pmaddl (rd rs1 rs2: ireg) (**r multiply-add long *) + | Pmsubl (rd rs1 rs2: ireg) (**r multiply-add long *) + + | Pfaddd (rd rs1 rs2: ireg) (**r Float addition double *) + | Pfaddw (rd rs1 rs2: ireg) (**r Float addition word *) + | Pfsbfd (rd rs1 rs2: ireg) (**r Float sub double *) + | Pfsbfw (rd rs1 rs2: ireg) (**r Float sub word *) + | Pfmuld (rd rs1 rs2: ireg) (**r Float mul double *) + | Pfmulw (rd rs1 rs2: ireg) (**r Float mul word *) + | Pfmind (rd rs1 rs2: ireg) (**r Float min double *) + | Pfminw (rd rs1 rs2: ireg) (**r Float min word *) + | Pfmaxd (rd rs1 rs2: ireg) (**r Float max double *) + | Pfmaxw (rd rs1 rs2: ireg) (**r Float max word *) + | Pfinvw (rd rs1: ireg) (**r Float invert word *) + + (** Arith RRI32 *) + | Pcompiw (it: itest) (rd rs: ireg) (imm: int) (**r comparison imm word *) + + | Paddiw (rd rs: ireg) (imm: int) (**r add imm word *) + | Paddxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r add imm word *) + | Prevsubiw (rd rs: ireg) (imm: int) (**r subtract imm word *) + | Prevsubxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r subtract imm word *) + | Pmuliw (rd rs: ireg) (imm: int) (**r mul imm word *) + | Pandiw (rd rs: ireg) (imm: int) (**r and imm word *) + | Pnandiw (rd rs: ireg) (imm: int) (**r nand imm word *) + | Poriw (rd rs: ireg) (imm: int) (**r or imm word *) + | Pnoriw (rd rs: ireg) (imm: int) (**r nor imm word *) + | Pxoriw (rd rs: ireg) (imm: int) (**r xor imm word *) + | Pnxoriw (rd rs: ireg) (imm: int) (**r nxor imm word *) + | Pandniw (rd rs: ireg) (imm: int) (**r andn imm word *) + | Porniw (rd rs: ireg) (imm: int) (**r orn imm word *) + | Psraiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word *) + | Psrxiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*) + | Psrliw (rd rs: ireg) (imm: int) (**r shift right logical imm word *) + | Pslliw (rd rs: ireg) (imm: int) (**r shift left logical imm word *) + | Proriw (rd rs: ireg) (imm: int) (**r rotate right imm word *) + | Pmaddiw (rd rs: ireg) (imm: int) (**r multiply add imm word *) + | Psllil (rd rs: ireg) (imm: int) (**r shift left logical immediate long *) + | Psrxil (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*) + | Psrlil (rd rs: ireg) (imm: int) (**r shift right logical immediate long *) + | Psrail (rd rs: ireg) (imm: int) (**r shift right arithmetic immediate long *) + + (** Arith RRI64 *) + | Pcompil (it: itest) (rd rs: ireg) (imm: int64) (**r comparison imm long *) + | Paddil (rd rs: ireg) (imm: int64) (**r add immediate long *) + | Paddxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r add immediate long *) + | Prevsubil (rd rs: ireg) (imm: int64) (**r subtract imm long *) + | Prevsubxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r subtract imm long *) + | Pmulil (rd rs: ireg) (imm: int64) (**r add immediate long *) + | Pandil (rd rs: ireg) (imm: int64) (**r and immediate long *) + | Pnandil (rd rs: ireg) (imm: int64) (**r and immediate long *) + | Poril (rd rs: ireg) (imm: int64) (**r or immediate long *) + | Pnoril (rd rs: ireg) (imm: int64) (**r and immediate long *) + | Pxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *) + | Pnxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *) + | Pandnil (rd rs: ireg) (imm: int64) (**r andn long *) + | Pornil (rd rs: ireg) (imm: int64) (**r orn long *) + | Pmaddil (rd rs: ireg) (imm: int64) (**r multiply add imm long *) + | Pcmove (bt: btest) (rcond rd rs : ireg) (** conditional move *) + | Pcmoveu (bt: btest) (rcond rd rs : ireg) (** conditional move, unsigned semantics *) + | Pcmoveiw (bt: btest) (rcond rd : ireg) (imm: int) (** conditional move *) + | Pcmoveuiw (bt: btest) (rcond rd : ireg) (imm: int) (** conditional move, unsigned semantics *) + | Pcmoveil (bt: btest) (rcond rd : ireg) (imm: int64) (** conditional move *) + | Pcmoveuil (bt: btest) (rcond rd : ireg) (imm: int64) (** conditional move, unsigned semantics *) +. + +(** Correspondance between Asmblock and Asm *) + +Definition control_to_instruction (c: control) := + match c with + | PExpand (Asmvliw.Pbuiltin ef args res) => Pbuiltin ef args res + | PCtlFlow Asmvliw.Pret => Pret + | PCtlFlow (Asmvliw.Pcall l) => Pcall l + | PCtlFlow (Asmvliw.Picall r) => Picall r + | PCtlFlow (Asmvliw.Pgoto l) => Pgoto l + | PCtlFlow (Asmvliw.Pigoto l) => Pigoto l + | PCtlFlow (Asmvliw.Pj_l l) => Pj_l l + | PCtlFlow (Asmvliw.Pcb bt r l) => Pcb bt r l + | PCtlFlow (Asmvliw.Pcbu bt r l) => Pcbu bt r l + | PCtlFlow (Asmvliw.Pjumptable r label) => Pjumptable r label + end. + +Definition basic_to_instruction (b: basic) := + match b with + (** Special basics *) + | Asmvliw.Pget rd rs => Pget rd rs + | Asmvliw.Pset rd rs => Pset rd rs + | Asmvliw.Pnop => Pnop + | Asmvliw.Pallocframe sz pos => Pallocframe sz pos + | Asmvliw.Pfreeframe sz pos => Pfreeframe sz pos + + (** PArith basics *) + (* R *) + | PArithR (Asmvliw.Ploadsymbol id ofs) r => Ploadsymbol r id ofs + + (* RR *) + | PArithRR Asmvliw.Pmv rd rs => Pmv rd rs + | PArithRR Asmvliw.Pnegw rd rs => Pnegw rd rs + | PArithRR Asmvliw.Pnegl rd rs => Pnegl rd rs + | PArithRR Asmvliw.Pcvtl2w rd rs => Pcvtl2w rd rs + | PArithRR Asmvliw.Psxwd rd rs => Psxwd rd rs + | PArithRR Asmvliw.Pzxwd rd rs => Pzxwd rd rs + | PArithRR (Asmvliw.Pextfz stop start) rd rs => Pextfz rd rs stop start + | PArithRR (Asmvliw.Pextfs stop start) rd rs => Pextfs rd rs stop start + | PArithRR (Asmvliw.Pextfzl stop start) rd rs => Pextfzl rd rs stop start + | PArithRR (Asmvliw.Pextfsl stop start) rd rs => Pextfsl rd rs stop start + | PArithRR Asmvliw.Pfabsd rd rs => Pfabsd rd rs + | PArithRR Asmvliw.Pfabsw rd rs => Pfabsw rd rs + | PArithRR Asmvliw.Pfnegd rd rs => Pfnegd rd rs + | PArithRR Asmvliw.Pfnegw rd rs => Pfnegw rd rs + | PArithRR Asmvliw.Pfinvw rd rs => Pfinvw rd rs + | PArithRR Asmvliw.Pfnarrowdw rd rs => Pfnarrowdw rd rs + | PArithRR Asmvliw.Pfwidenlwd rd rs => Pfwidenlwd rd rs + | PArithRR Asmvliw.Pfloatuwrnsz rd rs => Pfloatuwrnsz rd rs + | PArithRR Asmvliw.Pfloatwrnsz rd rs => Pfloatwrnsz rd rs + | PArithRR Asmvliw.Pfloatudrnsz rd rs => Pfloatudrnsz rd rs + | PArithRR Asmvliw.Pfloatdrnsz rd rs => Pfloatdrnsz rd rs + | PArithRR Asmvliw.Pfixedwrzz rd rs => Pfixedwrzz rd rs + | PArithRR Asmvliw.Pfixeduwrzz rd rs => Pfixeduwrzz rd rs + | PArithRR Asmvliw.Pfixeddrzz rd rs => Pfixeddrzz rd rs + | PArithRR Asmvliw.Pfixedudrzz rd rs => Pfixedudrzz rd rs + | PArithRR Asmvliw.Pfixeddrzz_i32 rd rs => Pfixeddrzz_i32 rd rs + | PArithRR Asmvliw.Pfixedudrzz_i32 rd rs => Pfixedudrzz_i32 rd rs + + (* RI32 *) + | PArithRI32 Asmvliw.Pmake rd imm => Pmake rd imm + + (* RI64 *) + | PArithRI64 Asmvliw.Pmakel rd imm => Pmakel rd imm + + (* RF32 *) + | PArithRF32 Asmvliw.Pmakefs rd imm => Pmakefs rd imm + + (* RF64 *) + | PArithRF64 Asmvliw.Pmakef rd imm => Pmakef rd imm + + (* RRR *) + | PArithRRR (Asmvliw.Pcompw it) rd rs1 rs2 => Pcompw it rd rs1 rs2 + | PArithRRR (Asmvliw.Pcompl it) rd rs1 rs2 => Pcompl it rd rs1 rs2 + | PArithRRR (Asmvliw.Pfcompw ft) rd rs1 rs2 => Pfcompw ft rd rs1 rs2 + | PArithRRR (Asmvliw.Pfcompl ft) rd rs1 rs2 => Pfcompl ft rd rs1 rs2 + | PArithRRR Asmvliw.Paddw rd rs1 rs2 => Paddw rd rs1 rs2 + | PArithRRR (Asmvliw.Paddxw shift) rd rs1 rs2 => Paddxw shift rd rs1 rs2 + | PArithRRR Asmvliw.Psubw rd rs1 rs2 => Psubw rd rs1 rs2 + | PArithRRR (Asmvliw.Prevsubxw shift) rd rs1 rs2 => Prevsubxw shift rd rs1 rs2 + | PArithRRR Asmvliw.Pmulw rd rs1 rs2 => Pmulw rd rs1 rs2 + | PArithRRR Asmvliw.Pandw rd rs1 rs2 => Pandw rd rs1 rs2 + | PArithRRR Asmvliw.Pnandw rd rs1 rs2 => Pnandw rd rs1 rs2 + | PArithRRR Asmvliw.Porw rd rs1 rs2 => Porw rd rs1 rs2 + | PArithRRR Asmvliw.Pnorw rd rs1 rs2 => Pnorw rd rs1 rs2 + | PArithRRR Asmvliw.Pxorw rd rs1 rs2 => Pxorw rd rs1 rs2 + | PArithRRR Asmvliw.Pnxorw rd rs1 rs2 => Pnxorw rd rs1 rs2 + | PArithRRR Asmvliw.Pandnw rd rs1 rs2 => Pandnw rd rs1 rs2 + | PArithRRR Asmvliw.Pornw rd rs1 rs2 => Pornw rd rs1 rs2 + | PArithRRR Asmvliw.Psraw rd rs1 rs2 => Psraw rd rs1 rs2 + | PArithRRR Asmvliw.Psrxw rd rs1 rs2 => Psrxw rd rs1 rs2 + | PArithRRR Asmvliw.Psrlw rd rs1 rs2 => Psrlw rd rs1 rs2 + | PArithRRR Asmvliw.Psllw rd rs1 rs2 => Psllw rd rs1 rs2 + + | PArithRRR Asmvliw.Paddl rd rs1 rs2 => Paddl rd rs1 rs2 + | PArithRRR (Asmvliw.Paddxl shift) rd rs1 rs2 => Paddxl shift rd rs1 rs2 + | PArithRRR Asmvliw.Psubl rd rs1 rs2 => Psubl rd rs1 rs2 + | PArithRRR (Asmvliw.Prevsubxl shift) rd rs1 rs2 => Prevsubxl shift rd rs1 rs2 + | PArithRRR Asmvliw.Pandl rd rs1 rs2 => Pandl rd rs1 rs2 + | PArithRRR Asmvliw.Pnandl rd rs1 rs2 => Pnandl rd rs1 rs2 + | PArithRRR Asmvliw.Porl rd rs1 rs2 => Porl rd rs1 rs2 + | PArithRRR Asmvliw.Pnorl rd rs1 rs2 => Pnorl rd rs1 rs2 + | PArithRRR Asmvliw.Pxorl rd rs1 rs2 => Pxorl rd rs1 rs2 + | PArithRRR Asmvliw.Pnxorl rd rs1 rs2 => Pnxorl rd rs1 rs2 + | PArithRRR Asmvliw.Pandnl rd rs1 rs2 => Pandnl rd rs1 rs2 + | PArithRRR Asmvliw.Pornl rd rs1 rs2 => Pornl rd rs1 rs2 + | PArithRRR Asmvliw.Pmull rd rs1 rs2 => Pmull rd rs1 rs2 + | PArithRRR Asmvliw.Pslll rd rs1 rs2 => Pslll rd rs1 rs2 + | PArithRRR Asmvliw.Psrll rd rs1 rs2 => Psrll rd rs1 rs2 + | PArithRRR Asmvliw.Psral rd rs1 rs2 => Psral rd rs1 rs2 + | PArithRRR Asmvliw.Psrxl rd rs1 rs2 => Psrxl rd rs1 rs2 + + | PArithRRR Asmvliw.Pfaddd rd rs1 rs2 => Pfaddd rd rs1 rs2 + | PArithRRR Asmvliw.Pfaddw rd rs1 rs2 => Pfaddw rd rs1 rs2 + | PArithRRR Asmvliw.Pfsbfd rd rs1 rs2 => Pfsbfd rd rs1 rs2 + | PArithRRR Asmvliw.Pfsbfw rd rs1 rs2 => Pfsbfw rd rs1 rs2 + | PArithRRR Asmvliw.Pfmuld rd rs1 rs2 => Pfmuld rd rs1 rs2 + | PArithRRR Asmvliw.Pfmulw rd rs1 rs2 => Pfmulw rd rs1 rs2 + | PArithRRR Asmvliw.Pfmind rd rs1 rs2 => Pfmind rd rs1 rs2 + | PArithRRR Asmvliw.Pfminw rd rs1 rs2 => Pfminw rd rs1 rs2 + | PArithRRR Asmvliw.Pfmaxd rd rs1 rs2 => Pfmaxd rd rs1 rs2 + | PArithRRR Asmvliw.Pfmaxw rd rs1 rs2 => Pfmaxw rd rs1 rs2 + + (* RRI32 *) + | PArithRRI32 (Asmvliw.Pcompiw it) rd rs imm => Pcompiw it rd rs imm + | PArithRRI32 Asmvliw.Paddiw rd rs imm => Paddiw rd rs imm + | PArithRRI32 (Asmvliw.Paddxiw shift) rd rs imm => Paddxiw shift rd rs imm + | PArithRRI32 Asmvliw.Prevsubiw rd rs imm => Prevsubiw rd rs imm + | PArithRRI32 (Asmvliw.Prevsubxiw shift) rd rs imm => Prevsubxiw shift rd rs imm + | PArithRRI32 Asmvliw.Pmuliw rd rs imm => Pmuliw rd rs imm + | PArithRRI32 Asmvliw.Pandiw rd rs imm => Pandiw rd rs imm + | PArithRRI32 Asmvliw.Pnandiw rd rs imm => Pnandiw rd rs imm + | PArithRRI32 Asmvliw.Poriw rd rs imm => Poriw rd rs imm + | PArithRRI32 Asmvliw.Pnoriw rd rs imm => Pnoriw rd rs imm + | PArithRRI32 Asmvliw.Pxoriw rd rs imm => Pxoriw rd rs imm + | PArithRRI32 Asmvliw.Pnxoriw rd rs imm => Pnxoriw rd rs imm + | PArithRRI32 Asmvliw.Pandniw rd rs imm => Pandniw rd rs imm + | PArithRRI32 Asmvliw.Porniw rd rs imm => Porniw rd rs imm + | PArithRRI32 Asmvliw.Psraiw rd rs imm => Psraiw rd rs imm + | PArithRRI32 Asmvliw.Psrxiw rd rs imm => Psrxiw rd rs imm + | PArithRRI32 Asmvliw.Psrliw rd rs imm => Psrliw rd rs imm + | PArithRRI32 Asmvliw.Pslliw rd rs imm => Pslliw rd rs imm + | PArithRRI32 Asmvliw.Proriw rd rs imm => Proriw rd rs imm + | PArithRRI32 Asmvliw.Psllil rd rs imm => Psllil rd rs imm + | PArithRRI32 Asmvliw.Psrlil rd rs imm => Psrlil rd rs imm + | PArithRRI32 Asmvliw.Psrxil rd rs imm => Psrxil rd rs imm + | PArithRRI32 Asmvliw.Psrail rd rs imm => Psrail rd rs imm + + (* RRI64 *) + | PArithRRI64 (Asmvliw.Pcompil it) rd rs imm => Pcompil it rd rs imm + | PArithRRI64 Asmvliw.Paddil rd rs imm => Paddil rd rs imm + | PArithRRI64 (Asmvliw.Paddxil shift) rd rs imm => Paddxil shift rd rs imm + | PArithRRI64 Asmvliw.Prevsubil rd rs imm => Prevsubil rd rs imm + | PArithRRI64 (Asmvliw.Prevsubxil shift) rd rs imm => Prevsubxil shift rd rs imm + | PArithRRI64 Asmvliw.Pmulil rd rs imm => Pmulil rd rs imm + | PArithRRI64 Asmvliw.Pandil rd rs imm => Pandil rd rs imm + | PArithRRI64 Asmvliw.Pnandil rd rs imm => Pnandil rd rs imm + | PArithRRI64 Asmvliw.Poril rd rs imm => Poril rd rs imm + | PArithRRI64 Asmvliw.Pnoril rd rs imm => Pnoril rd rs imm + | PArithRRI64 Asmvliw.Pxoril rd rs imm => Pxoril rd rs imm + | PArithRRI64 Asmvliw.Pnxoril rd rs imm => Pnxoril rd rs imm + | PArithRRI64 Asmvliw.Pandnil rd rs imm => Pandnil rd rs imm + | PArithRRI64 Asmvliw.Pornil rd rs imm => Pornil rd rs imm + + (** ARRR *) + | PArithARRR Asmvliw.Pmaddw rd rs1 rs2 => Pmaddw rd rs1 rs2 + | PArithARRR Asmvliw.Pmaddl rd rs1 rs2 => Pmaddl rd rs1 rs2 + | PArithARRR Asmvliw.Pmsubw rd rs1 rs2 => Pmsubw rd rs1 rs2 + | PArithARRR Asmvliw.Pmsubl rd rs1 rs2 => Pmsubl rd rs1 rs2 + | PArithARRR Asmvliw.Pfmaddfw rd rs1 rs2 => Pfmaddfw rd rs1 rs2 + | PArithARRR Asmvliw.Pfmaddfl rd rs1 rs2 => Pfmaddfl rd rs1 rs2 + | PArithARRR Asmvliw.Pfmsubfw rd rs1 rs2 => Pfmsubfw rd rs1 rs2 + | PArithARRR Asmvliw.Pfmsubfl rd rs1 rs2 => Pfmsubfl rd rs1 rs2 + | PArithARRR (Asmvliw.Pcmove cond) rd rs1 rs2=> Pcmove cond rd rs1 rs2 + | PArithARRR (Asmvliw.Pcmoveu cond) rd rs1 rs2=> Pcmoveu cond rd rs1 rs2 + + (** ARR *) + | PArithARR (Asmvliw.Pinsf stop start) rd rs => Pinsf rd rs stop start + | PArithARR (Asmvliw.Pinsfl stop start) rd rs => Pinsfl rd rs stop start + + (** ARRI32 *) + | PArithARRI32 Asmvliw.Pmaddiw rd rs1 imm => Pmaddiw rd rs1 imm + | PArithARRI32 (Asmvliw.Pcmoveiw cond) rd rs1 imm => Pcmoveiw cond rd rs1 imm + | PArithARRI32 (Asmvliw.Pcmoveuiw cond) rd rs1 imm => Pcmoveuiw cond rd rs1 imm + + (** ARRI64 *) + | PArithARRI64 Asmvliw.Pmaddil rd rs1 imm => Pmaddil rd rs1 imm + | PArithARRI64 (Asmvliw.Pcmoveil cond) rd rs1 imm => Pcmoveil cond rd rs1 imm + | PArithARRI64 (Asmvliw.Pcmoveuil cond) rd rs1 imm => Pcmoveuil cond rd rs1 imm + (** Load *) + | PLoadRRO trap Asmvliw.Plb rd ra ofs => Plb trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plbu rd ra ofs => Plbu trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plh rd ra ofs => Plh trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plhu rd ra ofs => Plhu trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plw rd ra ofs => Plw trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plw_a rd ra ofs => Plw_a trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Pld rd ra ofs => Pld trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Pld_a rd ra ofs => Pld_a trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Pfls rd ra ofs => Pfls trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Pfld rd ra ofs => Pfld trap rd ra (AOff ofs) + + | PLoadQRRO qrs ra ofs => Plq qrs ra (AOff ofs) + | PLoadORRO qrs ra ofs => Plo qrs ra (AOff ofs) + + | PLoadRRR trap Asmvliw.Plb rd ra ro => Plb trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plbu rd ra ro => Plbu trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plh rd ra ro => Plh trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plhu rd ra ro => Plhu trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plw rd ra ro => Plw trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plw_a rd ra ro => Plw_a trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Pld rd ra ro => Pld trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Pld_a rd ra ro => Pld_a trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Pfls rd ra ro => Pfls trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Pfld rd ra ro => Pfld trap rd ra (AReg ro) + + | PLoadRRRXS trap Asmvliw.Plb rd ra ro => Plb trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plbu rd ra ro => Plbu trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plh rd ra ro => Plh trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plhu rd ra ro => Plhu trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plw rd ra ro => Plw trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plw_a rd ra ro => Plw_a trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Pld rd ra ro => Pld trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Pld_a rd ra ro => Pld_a trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Pfls rd ra ro => Pfls trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Pfld rd ra ro => Pfld trap rd ra (ARegXS ro) + + (** Store *) + | PStoreRRO Asmvliw.Psb rd ra ofs => Psb rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psh rd ra ofs => Psh rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psw rd ra ofs => Psw rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psw_a rd ra ofs => Psw_a rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psd rd ra ofs => Psd rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psd_a rd ra ofs => Psd_a rd ra (AOff ofs) + | PStoreRRO Asmvliw.Pfss rd ra ofs => Pfss rd ra (AOff ofs) + | PStoreRRO Asmvliw.Pfsd rd ra ofs => Pfsd rd ra (AOff ofs) + + | PStoreRRR Asmvliw.Psb rd ra ro => Psb rd ra (AReg ro) + | PStoreRRR Asmvliw.Psh rd ra ro => Psh rd ra (AReg ro) + | PStoreRRR Asmvliw.Psw rd ra ro => Psw rd ra (AReg ro) + | PStoreRRR Asmvliw.Psw_a rd ra ro => Psw_a rd ra (AReg ro) + | PStoreRRR Asmvliw.Psd rd ra ro => Psd rd ra (AReg ro) + | PStoreRRR Asmvliw.Psd_a rd ra ro => Psd_a rd ra (AReg ro) + | PStoreRRR Asmvliw.Pfss rd ra ro => Pfss rd ra (AReg ro) + | PStoreRRR Asmvliw.Pfsd rd ra ro => Pfsd rd ra (AReg ro) + + | PStoreRRRXS Asmvliw.Psb rd ra ro => Psb rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psh rd ra ro => Psh rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psw rd ra ro => Psw rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psw_a rd ra ro => Psw_a rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psd rd ra ro => Psd rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psd_a rd ra ro => Psd_a rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Pfss rd ra ro => Pfss rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Pfsd rd ra ro => Pfsd rd ra (ARegXS ro) + + | PStoreQRRO qrs ra ofs => Psq qrs ra (AOff ofs) + | PStoreORRO qrs ra ofs => Pso qrs ra (AOff ofs) + end. + +Section RELSEM. + +Definition code := list instruction. + +Fixpoint unfold_label (ll: list label) := + match ll with + | nil => nil + | l :: ll => Plabel l :: unfold_label ll + end. + +Fixpoint unfold_body (lb: list basic) := + match lb with + | nil => nil + | b :: lb => basic_to_instruction b :: unfold_body lb + end. + +Definition unfold_exit (oc: option control) := + match oc with + | None => nil + | Some c => control_to_instruction c :: nil + end. + +Definition unfold_bblock (b: bblock) := unfold_label (header b) ++ + (match (body b), (exit b) with + | (((Asmvliw.Pfreeframe _ _ | Asmvliw.Pallocframe _ _)::nil) as bo), None => + unfold_body bo + | bo, ex => unfold_body bo ++ unfold_exit ex ++ Psemi :: nil + end). + +Fixpoint unfold (lb: bblocks) := + match lb with + | nil => nil + | b :: lb => (unfold_bblock b) ++ unfold lb + end. + +Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks; fn_code: code; + correct: unfold fn_blocks = fn_code }. + +Definition fundef := AST.fundef function. +Definition program := AST.program fundef unit. +Definition genv := Genv.t fundef unit. + +Definition function_proj (f: function) := Asmvliw.mkfunction (fn_sig f) (fn_blocks f). + +Definition fundef_proj (fu: fundef) : Asmvliw.fundef := + match fu with + | Internal f => Internal (function_proj f) + | External ef => External ef + end. + +Definition globdef_proj (gd: globdef fundef unit) : globdef Asmvliw.fundef unit := + match gd with + | Gfun f => Gfun (fundef_proj f) + | Gvar gu => Gvar gu + end. + +Program Definition genv_trans (ge: genv) : Asmvliw.genv := + {| Genv.genv_public := Genv.genv_public ge; + Genv.genv_symb := Genv.genv_symb ge; + Genv.genv_defs := PTree.map1 globdef_proj (Genv.genv_defs ge); + Genv.genv_next := Genv.genv_next ge |}. +Next Obligation. + destruct ge. simpl in *. eauto. +Qed. Next Obligation. + destruct ge; simpl in *. + rewrite PTree.gmap1 in H. + destruct (genv_defs ! b) eqn:GEN. + - eauto. + - discriminate. +Qed. Next Obligation. + destruct ge; simpl in *. + eauto. +Qed. + +Fixpoint prog_defs_proj (l: list (ident * globdef fundef unit)) + : list (ident * globdef Asmvliw.fundef unit) := + match l with + | nil => nil + | (i, gd) :: l => (i, globdef_proj gd) :: prog_defs_proj l + end. + +Definition program_proj (p: program) : Asmvliw.program := + {| prog_defs := prog_defs_proj (prog_defs p); + prog_public := prog_public p; + prog_main := prog_main p + |}. + +End RELSEM. + +Definition semantics (p: program) := Asmvliw.semantics (program_proj p). + +(** Determinacy of the [Asm] semantics. *) + +Lemma semantics_determinate: forall p, determinate (semantics p). +Proof. + intros. apply semantics_determinate. +Qed. + +(** transf_program *) + +Program Definition transf_function (f: Asmvliw.function) : function := + {| fn_sig := Asmvliw.fn_sig f; fn_blocks := Asmvliw.fn_blocks f; + fn_code := unfold (Asmvliw.fn_blocks f) |}. + +Lemma transf_function_proj: forall f, function_proj (transf_function f) = f. +Proof. + intros f. destruct f as [sig blks]. unfold function_proj. simpl. auto. +Qed. + +Definition transf_fundef : Asmvliw.fundef -> fundef := AST.transf_fundef transf_function. + +Lemma transf_fundef_proj: forall f, fundef_proj (transf_fundef f) = f. +Proof. + intros f. destruct f as [f|e]; simpl; auto. + rewrite transf_function_proj. auto. +Qed. + +Definition transf_program : Asmvliw.program -> program := transform_program transf_fundef. + +Lemma program_equals {A B: Type} : forall (p1 p2: AST.program A B), + prog_defs p1 = prog_defs p2 -> + prog_public p1 = prog_public p2 -> + prog_main p1 = prog_main p2 -> + p1 = p2. +Proof. + intros. destruct p1. destruct p2. simpl in *. subst. auto. +Qed. + +Lemma transf_program_proj: forall p, program_proj (transf_program p) = p. +Proof. + intros p. destruct p as [defs pub main]. unfold program_proj. simpl. + apply program_equals; simpl; auto. + induction defs. + - simpl; auto. + - simpl. rewrite IHdefs. + destruct a as [id gd]; simpl. + destruct gd as [f|v]; simpl; auto. + rewrite transf_fundef_proj. auto. +Qed. + +Definition match_prog (p: Asmvliw.program) (tp: program) := + match_program (fun _ f tf => tf = transf_fundef f) eq p tp. + +Lemma transf_program_match: + forall p tp, transf_program p = tp -> match_prog p tp. +Proof. + intros. rewrite <- H. eapply match_transform_program; eauto. +Qed. + +Lemma cons_extract {A: Type} : forall (l: list A) a b, a = b -> a::l = b::l. +Proof. + intros. congruence. +Qed. + +Lemma match_program_transf: + forall p tp, match_prog p tp -> transf_program p = tp. +Proof. + intros p tp H. inversion_clear H. inv H1. + destruct p as [defs pub main]. destruct tp as [tdefs tpub tmain]. simpl in *. + subst. unfold transf_program. unfold transform_program. simpl. + apply program_equals; simpl; auto. + induction H0; simpl; auto. + rewrite IHlist_forall2. apply cons_extract. + destruct a1 as [ida gda]. destruct b1 as [idb gdb]. + simpl in *. + inv H. inv H2. + - simpl in *. subst. auto. + - simpl in *. subst. inv H. auto. +Qed. + +Section PRESERVATION. + +Variable prog: Asmvliw.program. +Variable tprog: program. +Hypothesis TRANSF: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Definition match_states (s1 s2: state) := s1 = s2. + +Lemma symbols_preserved: + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof (Genv.find_symbol_match TRANSF). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). + + +Theorem transf_program_correct: + forward_simulation (Asmvliw.semantics prog) (semantics tprog). +Proof. + pose proof (match_program_transf prog tprog TRANSF) as TR. + subst. unfold semantics. rewrite transf_program_proj. + + eapply forward_simulation_step with (match_states := match_states); simpl; auto. + - intros. exists s1. split; auto. congruence. + - intros. inv H. auto. + - intros. exists s1'. inv H0. split; auto. congruence. +Qed. + +End PRESERVATION. diff --git a/mppa_k1c/Asmaux.v b/mppa_k1c/Asmaux.v index 85359658..891d1068 100644 --- a/mppa_k1c/Asmaux.v +++ b/mppa_k1c/Asmaux.v @@ -1,5 +1,5 @@ Require Import Asm. Require Import AST. -(* Constant only needed by Asmexpandaux.ml *) -Program Definition dummy_function := {| fn_code := nil; fn_sig := signature_main; fn_blocks := nil |}.
+(** Constant only needed by Asmexpandaux.ml *) +Program Definition dummy_function := {| fn_code := nil; fn_sig := signature_main; fn_blocks := nil |}. diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index ddb7ce7d..a05d4726 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -15,7 +15,7 @@ (* *) (* *********************************************************************) -(** Abstract syntax and semantics for K1c assembly language. *) +(** Sequential block semantics for K1c assembly. The syntax is given in AsmVLIW *) Require Import Coqlib. Require Import Maps. @@ -33,6 +33,19 @@ Require Import Conventions. Require Import Errors. Require Export Asmvliw. +(* Notations necessary to hook Asmvliw definitions *) +Notation undef_caller_save_regs := Asmvliw.undef_caller_save_regs. +Notation regset := Asmvliw.regset. +Notation extcall_arg := Asmvliw.extcall_arg. +Notation extcall_arg_pair := Asmvliw.extcall_arg_pair. +Notation extcall_arguments := Asmvliw.extcall_arguments. +Notation set_res := Asmvliw.set_res. +Notation function := Asmvliw.function. +Notation bblocks := Asmvliw.bblocks. +Notation header := Asmvliw.header. +Notation body := Asmvliw.body. +Notation exit := Asmvliw.exit. +Notation correct := Asmvliw.correct. (** * Auxiliary utilies on basic blocks *) @@ -172,7 +185,6 @@ Proof. Qed. Ltac bblock_auto_correct := (apply non_empty_bblock_refl; try discriminate; try (left; discriminate); try (right; discriminate)). -(* Local Obligation Tactic := bblock_auto_correct. *) Lemma Istrue_proof_irrelevant (b: bool): forall (p1 p2:Is_true b), p1=p2. Proof. @@ -250,9 +262,6 @@ Proof. intros. destruct bb as [hd bdy ex COR]. simpl. unfold no_header; unfold stick_header; simpl. reflexivity. Qed. - - - (** * Sequential Semantics of basic blocks *) Section RELSEM. @@ -264,11 +273,11 @@ Definition exec_arith_instr (ai: ar_instruction) (rs: regset): regset := parexec (** Auxiliaries for memory accesses *) -Definition exec_load_offset (chunk: memory_chunk) (rs: regset) (m: mem) (d a: ireg) (ofs: offset) := parexec_load_offset chunk rs rs m m d a ofs. +Definition exec_load_offset (trap: trapping_mode) (chunk: memory_chunk) (rs: regset) (m: mem) (d a: ireg) (ofs: offset) := parexec_load_offset trap chunk rs rs m m d a ofs. -Definition exec_load_reg (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: ireg) := parexec_load_reg chunk rs rs m m d a ro. +Definition exec_load_reg (trap: trapping_mode) (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: ireg) := parexec_load_reg trap chunk rs rs m m d a ro. -Definition exec_load_regxs (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: ireg) := parexec_load_regxs chunk rs rs m m d a ro. +Definition exec_load_regxs (trap: trapping_mode) (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: ireg) := parexec_load_regxs trap chunk rs rs m m d a ro. Definition exec_load_q_offset (rs: regset) (m: mem) (d : gpreg_q) (a: ireg) (ofs: offset) := parexec_load_q_offset rs rs m m d a ofs. @@ -286,7 +295,7 @@ Definition exec_store_regxs (chunk: memory_chunk) (rs: regset) (m: mem) (s a ro: (** * basic instructions *) -Definition exec_basic_instr (bi: basic) (rs: regset) (m: mem) : outcome := parexec_basic_instr ge bi rs rs m m. +Definition exec_basic_instr (bi: basic) (rs: regset) (m: mem) : outcome := bstep ge bi rs rs m m. Fixpoint exec_body (body: list basic) (rs: regset) (m: mem): outcome := match body with @@ -298,32 +307,36 @@ Fixpoint exec_body (body: list basic) (rs: regset) (m: mem): outcome := end end. -(** Position corresponding to a label *) - -Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) : outcome := par_goto_label f lbl rs rs m. - -(** Evaluating a branch - -Warning: in m PC is assumed to be already pointing on the next instruction ! -*) -Definition eval_branch (f: function) (l: label) (rs: regset) (m: mem) (res: option bool) : outcome := par_eval_branch f l rs rs m res. +Theorem builtin_body_nil: + forall bb ef args res, exit bb = Some (PExpand (Pbuiltin ef args res)) -> body bb = nil. +Proof. + intros. destruct bb as [hd bdy ex WF]. simpl in *. + apply wf_bblock_refl in WF. inv WF. unfold builtin_alone in H1. + eapply H1; eauto. +Qed. -(** Execution of a single control-flow instruction [i] in initial state [rs] and - [m]. Return updated state. +Theorem exec_body_app: + forall l l' rs m rs'' m'', + exec_body (l ++ l') rs m = Next rs'' m'' -> + exists rs' m', + exec_body l rs m = Next rs' m' + /\ exec_body l' rs' m' = Next rs'' m''. +Proof. + induction l. + - intros. simpl in H. repeat eexists. auto. + - intros. rewrite <- app_comm_cons in H. simpl in H. + destruct (exec_basic_instr a rs m) eqn:EXEBI. + + apply IHl in H. destruct H as (rs1 & m1 & EXEB1 & EXEB2). + repeat eexists. simpl. rewrite EXEBI. eauto. auto. + + discriminate. +Qed. - As above: PC is assumed to be incremented on the next block before the control-flow instruction +(** Position corresponding to a label *) - For instructions that correspond tobuiltin - actual RISC-V instructions, the cases are straightforward - transliterations of the informal descriptions given in the RISC-V - user-mode specification. For pseudo-instructions, refer to the - informal descriptions given above. +Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) : outcome := par_goto_label f lbl rs rs m. - Note that we set to [Vundef] the registers used as temporaries by - the expansions of the pseudo-instructions, so that the RISC-V code - we generate cannot use those registers to hold values that must - survive the execution of the pseudo-instruction. *) +Definition eval_branch (f: function) (l: label) (rs: regset) (m: mem) (res: option bool) : outcome := par_eval_branch f l rs rs m res. Definition exec_control (f: function) (oc: option control) (rs: regset) (m: mem) : outcome := parexec_control ge f oc rs rs m. @@ -368,16 +381,11 @@ Inductive step: state -> trace -> state -> Prop := step (State rs m) t (State rs' m') . - - End RELSEM. - - Definition semantics (p: program) := Semantics step (initial_state p) final_state (Genv.globalenv p). - Definition data_preg (r: preg) : bool := match r with | RA => false @@ -386,4 +394,3 @@ Definition data_preg (r: preg) : bool := | IR _ => true | PC => false end. - diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index eb3900d5..01eda623 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1,6 +1,13 @@ +(** * Translation from Asmblock to AbstractBB + + We define a specific instance of AbstractBB, named L, translate bblocks from Asmblock into this instance + AbstractBB will then define two semantics for L : a sequential, and a semantic one + We prove a bisimulation between the parallel semantics of L and AsmVLIW + From this, we also deduce a bisimulation between the sequential semantics of L and Asmblock *) + Require Import AST. Require Import Asmblock. -Require Import Asmblockgenproof0. +Require Import Asmblockgenproof0 Asmblockprops. Require Import Values. Require Import Globalenvs. Require Import Memory. @@ -9,14 +16,18 @@ Require Import Integers. Require Import Floats. Require Import ZArith. Require Import Coqlib. -Require Import ImpDep. +Require Import ImpSimuTest. Require Import Axioms. Require Import Parallelizability. Require Import Asmvliw Permutation. Require Import Chunks. +Require Import Lia. + Open Scope impure. +(** Definition of L *) + Module P<: ImpParam. Module R := Pos. @@ -74,9 +85,9 @@ Coercion OArithRRI32: arith_name_rri32 >-> Funclass. Coercion OArithRRI64: arith_name_rri64 >-> Funclass. Inductive load_op := - | OLoadRRO (n: load_name) (ofs: offset) - | OLoadRRR (n: load_name) - | OLoadRRRXS (n: load_name) + | OLoadRRO (n: load_name) (trap: trapping_mode) (ofs: offset) + | OLoadRRR (n: load_name) (trap: trapping_mode) + | OLoadRRRXS (n: load_name) (trap: trapping_mode) . Coercion OLoadRRO: load_name >-> Funclass. @@ -133,33 +144,39 @@ Definition arith_eval (ao: arith_op) (l: list value) := | _, _ => None end. -Definition exec_load_deps_offset (chunk: memory_chunk) (m: mem) (v: val) (ofs: offset) := +Definition exec_incorrect_load trap chunk := + match trap with + | TRAP => None + | NOTRAP => Some (Val (concrete_default_notrap_load_value chunk)) + end. + +Definition exec_load_deps_offset (trap: trapping_mode) (chunk: memory_chunk) (m: mem) (v: val) (ofs: offset) := let (ge, fn) := Ge in match (eval_offset ofs) with | OK ptr => match Mem.loadv chunk m (Val.offset_ptr v ptr) with - | None => None + | None => exec_incorrect_load trap chunk | Some vl => Some (Val vl) end | _ => None end. -Definition exec_load_deps_reg (chunk: memory_chunk) (m: mem) (v vo: val) := +Definition exec_load_deps_reg (trap: trapping_mode) (chunk: memory_chunk) (m: mem) (v vo: val) := match Mem.loadv chunk m (Val.addl v vo) with - | None => None + | None => exec_incorrect_load trap chunk | Some vl => Some (Val vl) end. -Definition exec_load_deps_regxs (chunk: memory_chunk) (m: mem) (v vo: val) := +Definition exec_load_deps_regxs (trap: trapping_mode) (chunk: memory_chunk) (m: mem) (v vo: val) := match Mem.loadv chunk m (Val.addl v (Val.shll vo (scale_of_chunk chunk))) with - | None => None + | None => exec_incorrect_load trap chunk | Some vl => Some (Val vl) end. Definition load_eval (lo: load_op) (l: list value) := match lo, l with - | OLoadRRO n ofs, [Val v; Memstate m] => exec_load_deps_offset (load_chunk n) m v ofs - | OLoadRRR n, [Val v; Val vo; Memstate m] => exec_load_deps_reg (load_chunk n) m v vo - | OLoadRRRXS n, [Val v; Val vo; Memstate m] => exec_load_deps_regxs (load_chunk n) m v vo + | OLoadRRO n trap ofs, [Val v; Memstate m] => exec_load_deps_offset trap (load_chunk n) m v ofs + | OLoadRRR n trap, [Val v; Val vo; Memstate m] => exec_load_deps_reg trap (load_chunk n) m v vo + | OLoadRRRXS n trap, [Val v; Val vo; Memstate m] => exec_load_deps_regxs trap (load_chunk n) m v vo | _, _ => None end. @@ -193,6 +210,136 @@ Definition store_eval (so: store_op) (l: list value) := | _, _ => None end. +Local Open Scope Z. + +Remark size_chunk_positive: forall chunk, + (size_chunk chunk) > 0. +Proof. + destruct chunk; simpl; lia. +Qed. + +Remark size_chunk_small: forall chunk, + (size_chunk chunk) <= 8. +Proof. + destruct chunk; simpl; lia. +Qed. + +Definition disjoint_chunks + (ofs1 : offset) (chunk1 : memory_chunk) + (ofs2 : offset) (chunk2 : memory_chunk) := + Intv.disjoint ((Ptrofs.unsigned ofs1), + ((Ptrofs.unsigned ofs1) + (size_chunk chunk1))) + ((Ptrofs.unsigned ofs2), + ((Ptrofs.unsigned ofs2) + (size_chunk chunk2))). + +Definition small_offset_threshold := 18446744073709551608. + +Lemma store_store_disjoint_offsets : + forall n1 n2 ofs1 ofs2 vs1 vs2 va m0 m1 m2 m1' m2', + (disjoint_chunks ofs1 (store_chunk n1) ofs2 (store_chunk n2)) -> + (Ptrofs.unsigned ofs1) < small_offset_threshold -> + (Ptrofs.unsigned ofs2) < small_offset_threshold -> + store_eval (OStoreRRO n1 ofs1) [vs1; va; Memstate m0] = Some (Memstate m1) -> + store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m1] = Some (Memstate m2) -> + store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m0] = Some (Memstate m1') -> + store_eval (OStoreRRO n1 ofs1) [vs1; va; Memstate m1'] = Some (Memstate m2') -> + m2 = m2'. +Proof. + intros until m2'. + intros DISJOINT SMALL1 SMALL2 STORE0 STORE1 STORE0' STORE1'. + unfold disjoint_chunks in DISJOINT. + destruct vs1 as [v1 | ]; simpl in STORE0, STORE1'; try congruence. + destruct vs2 as [v2 | ]; simpl in STORE1, STORE0'; try congruence. + destruct va as [base | ]; try congruence. + unfold exec_store_deps_offset in *. + destruct Ge. + unfold eval_offset in *; simpl in *. + unfold Mem.storev in *. + unfold Val.offset_ptr in *. + destruct base as [ | | | | | wblock wpofs] in * ; try congruence. + destruct (Mem.store _ _ _ _ _) eqn:E0; try congruence. + inv STORE0. + destruct (Mem.store (store_chunk n2) _ _ _ _) eqn:E1; try congruence. + inv STORE1. + destruct (Mem.store (store_chunk n2) m0 _ _ _) eqn:E0'; try congruence. + inv STORE0'. + destruct (Mem.store _ m1' _ _ _) eqn:E1'; try congruence. + inv STORE1'. + assert (Some m2 = Some m2'). + 2: congruence. + rewrite <- E1. + rewrite <- E1'. + eapply Mem.store_store_other. + 2, 3: eassumption. + + right. + pose proof (size_chunk_positive (store_chunk n1)). + pose proof (size_chunk_positive (store_chunk n2)). + pose proof (size_chunk_small (store_chunk n1)). + pose proof (size_chunk_small (store_chunk n2)). + destruct (Intv.range_disjoint _ _ DISJOINT) as [DIS | [DIS | DIS]]; + unfold Intv.empty in DIS; simpl in DIS. + 1, 2: lia. + pose proof (Ptrofs.unsigned_range ofs1). + pose proof (Ptrofs.unsigned_range ofs2). + unfold small_offset_threshold in *. + destruct (Ptrofs.unsigned_add_either wpofs ofs1) as [R1 | R1]; rewrite R1; + destruct (Ptrofs.unsigned_add_either wpofs ofs2) as [R2 | R2]; rewrite R2; + change Ptrofs.modulus with 18446744073709551616 in *; + lia. +Qed. + +Lemma load_store_disjoint_offsets : + forall n1 n2 tm ofs1 ofs2 vs va m0 m1, + (disjoint_chunks ofs1 (store_chunk n1) ofs2 (load_chunk n2)) -> + (Ptrofs.unsigned ofs1) < small_offset_threshold -> + (Ptrofs.unsigned ofs2) < small_offset_threshold -> + store_eval (OStoreRRO n1 ofs1) [vs; va; Memstate m0] = Some (Memstate m1) -> + load_eval (OLoadRRO n2 tm ofs2) [va; Memstate m1] = + load_eval (OLoadRRO n2 tm ofs2) [va; Memstate m0]. +Proof. + intros until m1. + intros DISJOINT SMALL1 SMALL2 STORE0. + destruct vs as [v | ]; simpl in STORE0; try congruence. + destruct va as [base | ]; try congruence. + unfold exec_store_deps_offset in *. + unfold eval_offset in *; simpl in *. + unfold exec_load_deps_offset. + unfold Mem.storev, Mem.loadv in *. + destruct Ge in *. + unfold eval_offset in *. + unfold Val.offset_ptr in *. + destruct base as [ | | | | | wblock wpofs] in * ; try congruence. + destruct (Mem.store _ _ _ _) eqn:E0; try congruence. + inv STORE0. + assert ( + (Mem.load (load_chunk n2) m1 wblock + (Ptrofs.unsigned (Ptrofs.add wpofs ofs2))) = + (Mem.load (load_chunk n2) m0 wblock + (Ptrofs.unsigned (Ptrofs.add wpofs ofs2))) ) as LOADS. + { + eapply Mem.load_store_other. + eassumption. + right. + pose proof (size_chunk_positive (store_chunk n1)). + pose proof (size_chunk_positive (load_chunk n2)). + pose proof (size_chunk_small (store_chunk n1)). + pose proof (size_chunk_small (load_chunk n2)). + destruct (Intv.range_disjoint _ _ DISJOINT) as [DIS | [DIS | DIS]]; + unfold Intv.empty in DIS; simpl in DIS. + 1,2: lia. + + pose proof (Ptrofs.unsigned_range ofs1). + pose proof (Ptrofs.unsigned_range ofs2). + unfold small_offset_threshold in *. + destruct (Ptrofs.unsigned_add_either wpofs ofs1) as [R1 | R1]; rewrite R1; + destruct (Ptrofs.unsigned_add_either wpofs ofs2) as [R2 | R2]; rewrite R2; + change Ptrofs.modulus with 18446744073709551616 in *; + lia. + } + destruct (Mem.load _ m1 _ _) in *; destruct (Mem.load _ m0 _ _) in *; congruence. +Qed. + Definition goto_label_deps (f: function) (lbl: label) (vpc: val) := match label_pos lbl 0 (fn_blocks f) with | None => None @@ -302,30 +449,6 @@ Definition op_eval (o: op) (l: list value) := end. - (** Function [is_constant] is used for a small optimization inside the scheduling verifier. - It is good that it answers [true] as much as possible while satisfying [is_constant_correct] below. - - BE CAREFUL that, [is_constant] must not depend on [ge]. - Otherwise, we would have an easy implementation: [match op_eval o nil with Some _ => true | _ => false end] - - => REM: when [is_constant] is not complete w.r.t [is_constant_correct], this should have only a very little impact - on the performance of the scheduling verifier... - *) - -Definition is_constant (o: op): bool := - match o with - | Constant _ | OArithR _ | OArithRI32 _ _ | OArithRI64 _ _ | OArithRF32 _ _ | OArithRF64 _ _ => true - | _ => false - end. - -Lemma is_constant_correct o: is_constant o = true -> op_eval o nil <> None. -Proof. - destruct o; simpl; try congruence. - destruct ao; simpl; try congruence; - destruct n; simpl; try congruence; - unfold arith_eval; destruct Ge; simpl; try congruence. -Qed. - Definition arith_op_eq (o1 o2: arith_op): ?? bool := match o1 with | OArithR n1 => @@ -379,24 +502,47 @@ Proof. Qed. Hint Resolve offset_eq_correct: wlp. +Definition trapping_mode_eq trap1 trap2 := + RET (match trap1, trap2 with + | TRAP, TRAP | NOTRAP, NOTRAP => true + | TRAP, NOTRAP | NOTRAP, TRAP => false + end). +Lemma trapping_mode_eq_correct t1 t2: + WHEN trapping_mode_eq t1 t2 ~> b THEN b = true -> t1 = t2. +Proof. + wlp_simplify. + destruct t1; destruct t2; trivial; discriminate. +Qed. +Hint Resolve trapping_mode_eq_correct: wlp. + Definition load_op_eq (o1 o2: load_op): ?? bool := match o1 with - | OLoadRRO n1 ofs1 => - match o2 with OLoadRRO n2 ofs2 => iandb (phys_eq n1 n2) (offset_eq ofs1 ofs2) | _ => RET false end - | OLoadRRR n1 => - match o2 with OLoadRRR n2 => phys_eq n1 n2 | _ => RET false end - | OLoadRRRXS n1 => - match o2 with OLoadRRRXS n2 => phys_eq n1 n2 | _ => RET false end + | OLoadRRO n1 trap ofs1 => + match o2 with + | OLoadRRO n2 trap2 ofs2 => iandb (phys_eq n1 n2) (iandb (offset_eq ofs1 ofs2) (trapping_mode_eq trap trap2)) + | _ => RET false + end + | OLoadRRR n1 trap => + match o2 with + | OLoadRRR n2 trap2 => iandb (phys_eq n1 n2) (trapping_mode_eq trap trap2) + | _ => RET false + end + | OLoadRRRXS n1 trap => + match o2 with + | OLoadRRRXS n2 trap2 => iandb (phys_eq n1 n2) (trapping_mode_eq trap trap2) + | _ => RET false + end end. Lemma load_op_eq_correct o1 o2: WHEN load_op_eq o1 o2 ~> b THEN b = true -> o1 = o2. Proof. destruct o1, o2; wlp_simplify; try discriminate. - - f_equal. pose (Ptrofs.eq_spec ofs ofs0). - rewrite H in *. trivial. - - congruence. - - congruence. + { f_equal. + destruct trap, trap0; simpl in *; trivial; discriminate. + pose (Ptrofs.eq_spec ofs ofs0). + rewrite H in *. trivial. } + all: destruct trap, trap0; simpl in *; trivial; discriminate. Qed. Hint Resolve load_op_eq_correct: wlp. Opaque load_op_eq_correct. @@ -483,18 +629,6 @@ Qed. Hint Resolve op_eq_correct: wlp. Global Opaque op_eq_correct. - -(* QUICK FIX WITH struct_eq *) - -(* Definition op_eq (o1 o2: op): ?? bool := struct_eq o1 o2. - -Theorem op_eq_correct o1 o2: - WHEN op_eq o1 o2 ~> b THEN b=true -> o1 = o2. -Proof. - wlp_simplify. -Qed. -*) - End IMPPARAM. End P. @@ -507,7 +641,7 @@ Include MkSeqLanguage P. End L. -Module IDT := ImpDepTree L ImpPosDict. +Module IST := ImpSimu L ImpPosDict. Import L. Import P. @@ -574,7 +708,7 @@ Proof. - unfold ppos. unfold pmem. discriminate. Qed. -(** Inversion functions, used for debugging *) +(** Inversion functions, used for debug traces *) Definition pos_to_ireg (p: R.t) : option gpreg := match p with @@ -598,9 +732,6 @@ Definition inv_ppos (p: R.t) : option preg := end end. - -(** Traduction Asmblock -> Asmblockdeps *) - Notation "a @ b" := (Econs a b) (at level 102, right associativity). Definition trans_control (ctl: control) : inst := @@ -647,21 +778,21 @@ Definition trans_arith (ai: ar_instruction) : inst := Definition trans_basic (b: basic) : inst := match b with | PArith ai => trans_arith ai - | PLoadRRO n d a ofs => [(#d, Op (Load (OLoadRRO n ofs)) (PReg (#a) @ PReg pmem @ Enil))] - | PLoadRRR n d a ro => [(#d, Op (Load (OLoadRRR n)) (PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] - | PLoadRRRXS n d a ro => [(#d, Op (Load (OLoadRRRXS n)) (PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] + | PLoadRRO trap n d a ofs => [(#d, Op (Load (OLoadRRO n trap ofs)) (PReg (#a) @ PReg pmem @ Enil))] + | PLoadRRR trap n d a ro => [(#d, Op (Load (OLoadRRR n trap)) (PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] + | PLoadRRRXS trap n d a ro => [(#d, Op (Load (OLoadRRRXS n trap)) (PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] | PStoreRRO n s a ofs => [(pmem, Op (Store (OStoreRRO n ofs)) (PReg (#s) @ PReg (#a) @ PReg pmem @ Enil))] | PLoadQRRO qd a ofs => let (d0, d1) := gpreg_q_expand qd in - [(#d0, Op (Load (OLoadRRO Pld_a ofs)) (PReg (#a) @ PReg pmem @ Enil)); - (#d1, Op (Load (OLoadRRO Pld_a (Ptrofs.add ofs (Ptrofs.repr 8)))) (Old(PReg (#a)) @ PReg pmem @ Enil))] + [(#d0, Op (Load (OLoadRRO Pld_a TRAP ofs)) (PReg (#a) @ PReg pmem @ Enil)); + (#d1, Op (Load (OLoadRRO Pld_a TRAP (Ptrofs.add ofs (Ptrofs.repr 8)))) (Old(PReg (#a)) @ PReg pmem @ Enil))] | PLoadORRO od a ofs => match gpreg_o_expand od with | (d0, d1, d2, d3) => - [(#d0, Op (Load (OLoadRRO Pld_a ofs)) (PReg (#a) @ PReg pmem @ Enil)); - (#d1, Op (Load (OLoadRRO Pld_a (Ptrofs.add ofs (Ptrofs.repr 8)))) (Old(PReg (#a)) @ PReg pmem @ Enil)); - (#d2, Op (Load (OLoadRRO Pld_a (Ptrofs.add ofs (Ptrofs.repr 16)))) (Old(PReg (#a)) @ PReg pmem @ Enil)); - (#d3, Op (Load (OLoadRRO Pld_a (Ptrofs.add ofs (Ptrofs.repr 24)))) (Old(PReg (#a)) @ PReg pmem @ Enil))] + [(#d0, Op (Load (OLoadRRO Pld_a TRAP ofs)) (PReg (#a) @ PReg pmem @ Enil)); + (#d1, Op (Load (OLoadRRO Pld_a TRAP (Ptrofs.add ofs (Ptrofs.repr 8)))) (Old(PReg (#a)) @ PReg pmem @ Enil)); + (#d2, Op (Load (OLoadRRO Pld_a TRAP (Ptrofs.add ofs (Ptrofs.repr 16)))) (Old(PReg (#a)) @ PReg pmem @ Enil)); + (#d3, Op (Load (OLoadRRO Pld_a TRAP (Ptrofs.add ofs (Ptrofs.repr 24)))) (Old(PReg (#a)) @ PReg pmem @ Enil))] end | PStoreRRR n s a ro => [(pmem, Op (Store (OStoreRRR n)) (PReg (#s) @ PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] | PStoreRRRXS n s a ro => [(pmem, Op (Store (OStoreRRRXS n)) (PReg (#s) @ PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] @@ -744,7 +875,7 @@ Proof. intros. congruence. Qed. -(** Parallelizability of a bblock (bundle) *) +(** Parallelizability test of a bblock (bundle), and bisimulation of the Asmblock and L parallel semantics *) Module PChk := ParallelChecks L PosPseudoRegSet. @@ -866,15 +997,15 @@ Qed. -Theorem forward_simu_par_wio_basic ge fn rsr rsw mr mw sr sw bi: +Theorem bisimu_par_wio_basic ge fn rsr rsw mr mw sr sw bi: Ge = Genv ge fn -> match_states (State rsr mr) sr -> match_states (State rsw mw) sw -> - match_outcome (parexec_basic_instr ge bi rsr rsw mr mw) (inst_prun Ge (trans_basic bi) sw sr sr). + match_outcome (bstep ge bi rsr rsw mr mw) (inst_prun Ge (trans_basic bi) sw sr sr). Proof. (* a little tactic to automate reasoning on preg_eq *) -Local Hint Resolve not_eq_sym ppos_pmem_discr ppos_discr. +Local Hint Resolve not_eq_sym ppos_pmem_discr ppos_discr: core. Local Ltac preg_eq_discr r rd := destruct (preg_eq r rd); try (subst r; rewrite assign_eq, Pregmap.gss; auto); rewrite (assign_diff _ (#rd) (#r) _); auto; @@ -891,21 +1022,21 @@ Local Ltac preg_eq_discr r rd := unfold parexec_load_offset; simpl; unfold exec_load_deps_offset; erewrite GENV, H, H0; unfold eval_offset; simpl; auto; - destruct (Mem.loadv _ _ _) eqn:MEML; simpl; auto; + destruct (Mem.loadv _ _ _) eqn:MEML; destruct trap; simpl; auto; eexists; split; try split; Simpl; intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. (* Load Reg *) + destruct i; simpl load_chunk. all: unfold parexec_load_reg; simpl; unfold exec_load_deps_reg; rewrite H, H0; rewrite (H0 rofs); - destruct (Mem.loadv _ _ _) eqn:MEML; simpl; auto; + destruct (Mem.loadv _ _ _) eqn:MEML; destruct trap; simpl; auto; eexists; split; try split; Simpl; intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. (* Load Reg XS *) + destruct i; simpl load_chunk. all: unfold parexec_load_regxs; simpl; unfold exec_load_deps_regxs; rewrite H, H0; rewrite (H0 rofs); - destruct (Mem.loadv _ _ _) eqn:MEML; simpl; auto; + destruct (Mem.loadv _ _ _) eqn:MEML; destruct trap; simpl; auto; eexists; split; try split; Simpl; intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. @@ -922,7 +1053,7 @@ Local Ltac preg_eq_discr r rd := preg_eq_discr r rd0. } (* Load Octuple word *) - + Local Hint Resolve not_eq_sym ppos_pmem_discr ppos_discr. + + Local Hint Resolve not_eq_sym ppos_pmem_discr ppos_discr: core. unfold parexec_load_o_offset. destruct (gpreg_o_expand rd) as [[[rd0 rd1] rd2] rd3]; destruct Ge; simpl. rewrite H0, H. @@ -1018,7 +1149,7 @@ Local Ltac preg_eq_discr r rd := Qed. -Theorem forward_simu_par_body: +Theorem bisimu_par_body: forall bdy ge fn rsr mr sr rsw mw sw, Ge = Genv ge fn -> match_states (State rsr mr) sr -> @@ -1027,19 +1158,19 @@ Theorem forward_simu_par_body: Proof. induction bdy as [|i bdy]; simpl; eauto. intros. - exploit (forward_simu_par_wio_basic ge fn rsr rsw mr mw sr sw i); eauto. - destruct (parexec_basic_instr _ _ _ _ _ _); simpl. + exploit (bisimu_par_wio_basic ge fn rsr rsw mr mw sr sw i); eauto. + destruct (bstep _ _ _ _ _ _); simpl. - intros (s' & X1 & X2). rewrite X1; simpl; eauto. - intros X; rewrite X; simpl; auto. Qed. -Theorem forward_simu_par_control ex sz aux ge fn rsr rsw mr mw sr sw: +Theorem bisimu_par_control ex sz aux ge fn rsr rsw mr mw sr sw: Ge = Genv ge fn -> match_states (State rsr mr) sr -> match_states (State rsw mw) sw -> match_outcome (parexec_control ge fn ex (incrPC (Ptrofs.repr sz) rsr) (rsw#PC <- aux) mw) (inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr). Proof. - intros GENV MSR MSW; unfold parexec_exit. + intros GENV MSR MSW; unfold estep. simpl in *. inv MSR. inv MSW. destruct ex. - destruct c; destruct i; try discriminate; simpl. @@ -1091,54 +1222,52 @@ Proof. intros rr; destruct rr; unfold incrPC; Simpl. Qed. -Theorem forward_simu_par_exit ex sz ge fn rsr rsw mr mw sr sw: +Theorem bisimu_par_exit ex sz ge fn rsr rsw mr mw sr sw: Ge = Genv ge fn -> match_states (State rsr mr) sr -> match_states (State rsw mw) sw -> - match_outcome (parexec_exit ge fn ex (Ptrofs.repr sz) rsr rsw mw) (inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr). + match_outcome (estep ge fn ex (Ptrofs.repr sz) rsr rsw mw) (inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr). Proof. - intros; unfold parexec_exit. - exploit (forward_simu_par_control ex sz rsw#PC ge fn rsr rsw mr mw sr sw); eauto. + intros; unfold estep. + exploit (bisimu_par_control ex sz rsw#PC ge fn rsr rsw mr mw sr sw); eauto. cutrewrite (rsw # PC <- (rsw PC) = rsw); auto. apply extensionality. intros; destruct x; simpl; auto. Qed. Definition trans_block_aux bdy sz ex := (trans_body bdy) ++ (trans_pcincr sz (trans_exit ex) :: nil). -Theorem forward_simu_par_wio_bblock_aux ge fn rsr mr sr rsw mw sw bdy ex sz: +Theorem bisimu_par_wio ge fn rsr mr sr bdy ex sz: Ge = Genv ge fn -> match_states (State rsr mr) sr -> - match_states (State rsw mw) sw -> - match_outcome (parexec_wio_bblock_aux ge fn bdy ex (Ptrofs.repr sz) rsr rsw mr mw) (prun_iw Ge (trans_block_aux bdy sz ex) sw sr). + match_outcome (parexec_wio ge fn bdy ex (Ptrofs.repr sz) rsr mr) (prun_iw Ge (trans_block_aux bdy sz ex) sr sr). Proof. - intros GENV MSR MSW. unfold parexec_wio_bblock_aux, trans_block_aux. - exploit (forward_simu_par_body bdy ge fn rsr mr sr rsw mw sw); eauto. + intros GENV MSR. unfold parexec_wio, trans_block_aux. + exploit (bisimu_par_body bdy ge fn rsr mr sr rsr mr sr); eauto. destruct (parexec_wio_body _ _ _ _ _ _); simpl. - intros (s' & X1 & X2). erewrite prun_iw_app_Some; eauto. - exploit (forward_simu_par_exit ex sz ge fn rsr rs mr m sr s'); eauto. + exploit (bisimu_par_exit ex sz ge fn rsr rs mr m sr s'); eauto. subst Ge; simpl. destruct MSR as (Y1 & Y2). erewrite Y2; simpl. destruct (inst_prun _ _ _ _ _); simpl; auto. - intros X; erewrite prun_iw_app_None; eauto. Qed. -Theorem forward_simu_par_wio_bblock ge fn rsr rsw mr sr sw mw bdy1 bdy2 ex sz: +Theorem bisimu_par_wio_bblock ge fn rsr mr sr bdy1 bdy2 ex sz: Ge = Genv ge fn -> match_states (State rsr mr) sr -> - match_states (State rsw mw) sw -> match_outcome - match parexec_wio_bblock_aux ge fn bdy1 ex (Ptrofs.repr sz) rsr rsw mr mw with + match parexec_wio ge fn bdy1 ex (Ptrofs.repr sz) rsr mr with | Next rs' m' => parexec_wio_body ge bdy2 rsr rs' mr m' | Stuck => Stuck end - (prun_iw Ge ((trans_block_aux bdy1 sz ex)++(trans_body bdy2)) sw sr). + (prun_iw Ge ((trans_block_aux bdy1 sz ex)++(trans_body bdy2)) sr sr). Proof. intros. - exploit (forward_simu_par_wio_bblock_aux ge fn rsr mr sr rsw mw sw bdy1 ex sz); eauto. - destruct (parexec_wio_bblock_aux _ _ _ _ _ _); simpl. + exploit (bisimu_par_wio ge fn rsr mr sr bdy1 ex sz); eauto. + destruct (parexec_wio _ _ _ _ _ _); simpl. - intros (s' & X1 & X2). erewrite prun_iw_app_Some; eauto. - eapply forward_simu_par_body; eauto. + eapply bisimu_par_body; eauto. - intros; erewrite prun_iw_app_None; eauto. Qed. @@ -1169,7 +1298,7 @@ Proof. apply Permutation_app_comm. Qed. -Theorem forward_simu_par rs1 m1 s1' b ge fn o2: +Theorem bisimu_par rs1 m1 s1' b ge fn o2: Ge = Genv ge fn -> match_states (State rs1 m1) s1' -> parexec_bblock ge fn b rs1 m1 o2 -> @@ -1181,24 +1310,24 @@ Proof. inversion PAREXEC as (bdy1 & bdy2 & PERM & WIO). exploit trans_block_perserves_permutation; eauto. intros Perm. - exploit (forward_simu_par_wio_bblock ge fn rs1 rs1 m1 s1' s1' m1 bdy1 bdy2 (exit b) (size b)); eauto. + exploit (bisimu_par_wio_bblock ge fn rs1 m1 s1' bdy1 bdy2 (exit b) (size b)); eauto. rewrite <- WIO. clear WIO. intros H; eexists; split. 2: eapply H. unfold prun; eexists; split; eauto. destruct (prun_iw _ _ _ _); simpl; eauto. Qed. -(* sequential execution *) -Theorem forward_simu_basic ge fn bi rs m s: +(** sequential execution *) +Theorem bisimu_basic ge fn bi rs m s: Ge = Genv ge fn -> match_states (State rs m) s -> match_outcome (exec_basic_instr ge bi rs m) (inst_run Ge (trans_basic bi) s s). Proof. intros; unfold exec_basic_instr. rewrite inst_run_prun. - eapply forward_simu_par_wio_basic; eauto. + eapply bisimu_par_wio_basic; eauto. Qed. -Lemma forward_simu_body: +Lemma bisimu_body: forall bdy ge fn rs m s, Ge = Genv ge fn -> match_states (State rs m) s -> @@ -1206,33 +1335,33 @@ Lemma forward_simu_body: Proof. induction bdy as [|i bdy]; simpl; eauto. intros. - exploit (forward_simu_basic ge fn i rs m s); eauto. + exploit (bisimu_basic ge fn i rs m s); eauto. destruct (exec_basic_instr _ _ _ _); simpl. - intros (s' & X1 & X2). rewrite X1; simpl; eauto. - intros X; rewrite X; simpl; auto. Qed. -Theorem forward_simu_exit ge fn b rs m s: +Theorem bisimu_exit ge fn b rs m s: Ge = Genv ge fn -> match_states (State rs m) s -> match_outcome (exec_control ge fn (exit b) (nextblock b rs) m) (inst_run Ge (trans_pcincr (size b) (trans_exit (exit b))) s s). Proof. intros; unfold exec_control, nextblock. rewrite inst_run_prun. - apply (forward_simu_par_control (exit b) (size b) (Val.offset_ptr (rs PC) (Ptrofs.repr (size b))) ge fn rs rs m m s s); auto. + apply (bisimu_par_control (exit b) (size b) (Val.offset_ptr (rs PC) (Ptrofs.repr (size b))) ge fn rs rs m m s s); auto. Qed. -Theorem forward_simu rs m b ge fn s: +Theorem bisimu rs m b ge fn s: Ge = Genv ge fn -> match_states (State rs m) s -> match_outcome (exec_bblock ge fn b rs m) (exec Ge (trans_block b) s). Proof. intros GENV MS. unfold exec_bblock. - exploit (forward_simu_body (body b) ge fn rs m s); eauto. + exploit (bisimu_body (body b) ge fn rs m s); eauto. unfold exec, trans_block; simpl. destruct (exec_body _ _ _ _); simpl. - intros (s' & X1 & X2). erewrite run_app_Some; eauto. - exploit (forward_simu_exit ge fn b rs0 m0 s'); eauto. + exploit (bisimu_exit ge fn b rs0 m0 s'); eauto. subst Ge; simpl. destruct X2 as (Y1 & Y2). erewrite Y2; simpl. destruct (inst_run _ _ _); simpl; auto. - intros X; erewrite run_app_None; eauto. @@ -1269,10 +1398,10 @@ Lemma bblock_para_check_correct ge fn bb rs m rs' m': det_parexec ge fn bb rs m rs' m'. Proof. intros H H0 H1 o H2. unfold bblock_para_check in H1. - exploit (forward_simu rs m bb ge fn); eauto. eapply trans_state_match. + exploit (bisimu rs m bb ge fn); eauto. eapply trans_state_match. rewrite H0; simpl. intros (s2' & EXEC & MS). - exploit forward_simu_par. 2: apply (trans_state_match (State rs m)). all: eauto. + exploit bisimu_par. 2: apply (trans_state_match (State rs m)). all: eauto. intros (o2' & PRUN & MO). exploit parallelizable_correct. apply is_para_correct_aux. eassumption. intro. eapply H3 in PRUN. clear H3. destruct o2'. @@ -1290,24 +1419,23 @@ Qed. End SECT_PAR. - Section SECT_BBLOCK_EQUIV. Variable Ge: genv. -Local Hint Resolve trans_state_match. +Local Hint Resolve trans_state_match: core. Lemma bblock_simu_reduce: forall p1 p2 ge fn, Ge = Genv ge fn -> L.bblock_simu Ge (trans_block p1) (trans_block p2) -> - Asmblockgenproof0.bblock_simu ge fn p1 p2. + Asmblockprops.bblock_simu ge fn p1 p2. Proof. unfold bblock_simu, res_eq; intros p1 p2 ge fn H1 H2 rs m DONTSTUCK. generalize (H2 (trans_state (State rs m))); clear H2. intro H2. - exploit (forward_simu Ge rs m p1 ge fn (trans_state (State rs m))); eauto. - exploit (forward_simu Ge rs m p2 ge fn (trans_state (State rs m))); eauto. + exploit (bisimu Ge rs m p1 ge fn (trans_state (State rs m))); eauto. + exploit (bisimu Ge rs m p2 ge fn (trans_state (State rs m))); eauto. destruct (exec_bblock ge fn p1 rs m); try congruence. intros H3 (s2' & exp2 & MS'). unfold exec in exp2, H3. rewrite exp2 in H2. destruct H2 as (m2' & H2 & H4). discriminate. rewrite H2 in H3. @@ -1320,6 +1448,8 @@ Proof. * discriminate. Qed. +(** Used for debug traces *) + Definition gpreg_name (gpr: gpreg) := match gpr with | GPR0 => Str ("GPR0") | GPR1 => Str ("GPR1") | GPR2 => Str ("GPR2") | GPR3 => Str ("GPR3") | GPR4 => Str ("GPR4") @@ -1369,6 +1499,7 @@ Definition string_of_name_rr (n: arith_name_rr): pstring := | Pfabsw => "Pfabsw" | Pfnegd => "Pfnegd" | Pfnegw => "Pfnegw" + | Pfinvw => "Pfinvw" | Pfnarrowdw => "Pfnarrowdw" | Pfwidenlwd => "Pfwidenlwd" | Pfloatwrnsz => "Pfloatwrnsz" @@ -1405,12 +1536,14 @@ Definition string_of_name_rf64 (n: arith_name_rf64): pstring := Definition string_of_name_rrr (n: arith_name_rrr): pstring := match n with - Pcompw _ => "Pcompw" + | Pcompw _ => "Pcompw" | Pcompl _ => "Pcompl" | Pfcompw _ => "Pfcompw" | Pfcompl _ => "Pfcompl" | Paddw => "Paddw" + | Paddxw _ => "Paddxw" | Psubw => "Psubw" + | Prevsubxw _ => "Prevsubxw" | Pmulw => "Pmulw" | Pandw => "Pandw" | Pnandw => "Pnandw" @@ -1425,7 +1558,9 @@ Definition string_of_name_rrr (n: arith_name_rrr): pstring := | Psrxw => "Psrxw" | Psllw => "Psllw" | Paddl => "Paddl" + | Paddxl _ => "Paddxl" | Psubl => "Psubl" + | Prevsubxl _ => "Prevsubxl" | Pandl => "Pandl" | Pnandl => "Pnandl" | Porl => "Porl" @@ -1445,12 +1580,19 @@ Definition string_of_name_rrr (n: arith_name_rrr): pstring := | Pfsbfw => "Pfsbfw" | Pfmuld => "Pfmuld" | Pfmulw => "Pfmulw" + | Pfmind => "Pfmind" + | Pfminw => "Pfminw" + | Pfmaxd => "Pfmaxd" + | Pfmaxw => "Pfmaxw" end. Definition string_of_name_rri32 (n: arith_name_rri32): pstring := match n with Pcompiw _ => "Pcompiw" | Paddiw => "Paddiw" + | Paddxiw _ => "Paddxiw" + | Prevsubiw => "Prevsubiw" + | Prevsubxiw _ => "Prevsubxiw" | Pmuliw => "Pmuliw" | Pandiw => "Pandiw" | Pnandiw => "Pnandiw" @@ -1475,6 +1617,9 @@ Definition string_of_name_rri64 (n: arith_name_rri64): pstring := match n with Pcompil _ => "Pcompil" | Paddil => "Paddil" + | Prevsubil => "Prevsubil" + | Paddxil _ => "Paddxil" + | Prevsubxil _ => "Prevsubxil" | Pmulil => "Pmulil" | Pandil => "Pandil" | Pnandil => "Pnandil" @@ -1490,8 +1635,14 @@ Definition string_of_name_arrr (n: arith_name_arrr): pstring := match n with | Pmaddw => "Pmaddw" | Pmaddl => "Pmaddl" + | Pmsubw => "Pmsubw" + | Pmsubl => "Pmsubl" | Pcmove _ => "Pcmove" | Pcmoveu _ => "Pcmoveu" + | Pfmaddfw => "Pfmaddfw" + | Pfmaddfl => "Pfmaddfl" + | Pfmsubfw => "Pfmsubfw" + | Pfmsubfl => "Pfmsubfl" end. Definition string_of_name_arr (n: arith_name_arr): pstring := @@ -1503,11 +1654,15 @@ Definition string_of_name_arr (n: arith_name_arr): pstring := Definition string_of_name_arri32 (n: arith_name_arri32): pstring := match n with | Pmaddiw => "Pmaddw" + | Pcmoveiw _ => "Pcmoveiw" + | Pcmoveuiw _ => "Pcmoveuiw" end. Definition string_of_name_arri64 (n: arith_name_arri64): pstring := match n with | Pmaddil => "Pmaddl" + | Pcmoveil _ => "Pcmoveil" + | Pcmoveuil _ => "Pcmoveuil" end. Definition string_of_arith (op: arith_op): pstring := @@ -1543,9 +1698,9 @@ Definition string_of_load_name (n: load_name) : pstring := Definition string_of_load (op: load_op): pstring := match op with - | OLoadRRO n _ => string_of_load_name n - | OLoadRRR n => string_of_load_name n - | OLoadRRRXS n => string_of_load_name n + | OLoadRRO n _ _ => string_of_load_name n + | OLoadRRR n _ => string_of_load_name n + | OLoadRRRXS n _ => string_of_load_name n end. Definition string_of_store_name (n: store_name) : pstring := @@ -1593,16 +1748,46 @@ Definition string_of_op (op: P.op): ?? pstring := | Fail => RET (Str "Fail") end. +End SECT_BBLOCK_EQUIV. + +(** REWRITE RULES *) + +Definition is_constant (o: op): bool := + match o with + | Constant _ | OArithR _ | OArithRI32 _ _ | OArithRI64 _ _ | OArithRF32 _ _ | OArithRF64 _ _ => true + | _ => false + end. + +Lemma is_constant_correct ge o: is_constant o = true -> op_eval ge o [] <> None. +Proof. + destruct o; simpl in * |- *; try congruence. + destruct ao; simpl in * |- *; try congruence; + destruct n; simpl in * |- *; try congruence; + unfold arith_eval; destruct ge; simpl in * |- *; try congruence. +Qed. + +Definition main_reduce (t: Terms.term):= RET (Terms.nofail is_constant t). + +Local Hint Resolve is_constant_correct: wlp. + +Lemma main_reduce_correct t: + WHEN main_reduce t ~> pt THEN Terms.match_pt t pt. +Proof. + wlp_simplify. +Qed. + +Definition reduce := {| Terms.result := main_reduce; Terms.result_correct := main_reduce_correct |}. + Definition bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock) : ?? bool := if verb then - IDT.verb_bblock_simu_test string_of_name string_of_op (trans_block p1) (trans_block p2) + IST.verb_bblock_simu_test reduce string_of_name string_of_op (trans_block p1) (trans_block p2) else - IDT.bblock_simu_test (trans_block p1) (trans_block p2). + IST.bblock_simu_test reduce (trans_block p1) (trans_block p2). -Local Hint Resolve IDT.bblock_simu_test_correct bblock_simu_reduce IDT.verb_bblock_simu_test_correct: wlp. +Local Hint Resolve IST.bblock_simu_test_correct bblock_simu_reduce IST.verb_bblock_simu_test_correct: wlp. Theorem bblock_simu_test_correct verb p1 p2 : - WHEN bblock_simu_test verb p1 p2 ~> b THEN b=true -> forall ge fn, Ge = Genv ge fn -> Asmblockgenproof0.bblock_simu ge fn p1 p2. + WHEN bblock_simu_test verb p1 p2 ~> b THEN b=true -> forall ge fn, Asmblockprops.bblock_simu ge fn p1 p2. Proof. wlp_simplify. Qed. @@ -1612,19 +1797,23 @@ Hint Resolve bblock_simu_test_correct: wlp. Import UnsafeImpure. -Definition pure_bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock): bool := unsafe_coerce (bblock_simu_test verb p1 p2). +Definition pure_bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock): bool := + match unsafe_coerce (bblock_simu_test verb p1 p2) with + | Some b => b + | None => false + end. -Theorem pure_bblock_simu_test_correct verb p1 p2 ge fn: Ge = Genv ge fn -> pure_bblock_simu_test verb p1 p2 = true -> Asmblockgenproof0.bblock_simu ge fn p1 p2. +Theorem pure_bblock_simu_test_correct verb p1 p2 ge fn: pure_bblock_simu_test verb p1 p2 = true -> Asmblockprops.bblock_simu ge fn p1 p2. Proof. - intros; unfold pure_bblock_simu_test. intros; eapply bblock_simu_test_correct; eauto. + unfold pure_bblock_simu_test. + destruct (unsafe_coerce (bblock_simu_test verb p1 p2)) eqn: UNSAFE; try discriminate. + intros; subst. eapply bblock_simu_test_correct; eauto. apply unsafe_coerce_not_really_correct; eauto. Qed. Definition bblock_simub: Asmvliw.bblock -> Asmvliw.bblock -> bool := pure_bblock_simu_test true. -Lemma bblock_simub_correct p1 p2 ge fn: Ge = Genv ge fn -> bblock_simub p1 p2 = true -> Asmblockgenproof0.bblock_simu ge fn p1 p2. +Lemma bblock_simub_correct p1 p2 ge fn: bblock_simub p1 p2 = true -> Asmblockprops.bblock_simu ge fn p1 p2. Proof. eapply (pure_bblock_simu_test_correct true). Qed. - -End SECT_BBLOCK_EQUIV. diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index a4364051..36269954 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -15,7 +15,8 @@ (* *) (* *********************************************************************) -(** Translation from Machblock to K1c assembly language (Asmblock) *) +(** * Translation from Machblock to K1c assembly language (Asmblock) + Inspired from the Mach->Asm pass of other backends, but adapted to the block structure *) Require Archi. Require Import Coqlib Errors. @@ -27,6 +28,8 @@ Require Import Chunks. Local Open Scope string_scope. Local Open Scope error_monad_scope. +Import PArithCoercions. + (** The code generation functions take advantage of several characteristics of the [Mach] code generated by earlier passes of the compiler, mostly that argument and result registers are of the correct @@ -41,23 +44,15 @@ Definition ireg_of (r: mreg) : res ireg := Definition freg_of (r: mreg) : res freg := match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgenblock.freg_of") end. -(* -(** Decomposition of 32-bit integer constants. They are split into either - small signed immediates that fit in 12-bits, or, if they do not fit, - into a (20-bit hi, 12-bit lo) pair where lo is sign-extended. *) - -*) Inductive immed32 : Type := | Imm32_single (imm: int). Definition make_immed32 (val: int) := Imm32_single val. -(** Likewise, for 64-bit integer constants. *) Inductive immed64 : Type := | Imm64_single (imm: int64) . -(* For now, let's suppose all instructions of K1c can handle 64-bits immediate *) Definition make_immed64 (val: int64) := Imm64_single val. Notation "a ::g b" := (cons (A:=instruction) a b) (at level 49, right associativity). @@ -66,12 +61,6 @@ Notation "a ::b lb" := ((bblock_single_inst a) :: lb) (at level 49, right associ Notation "a ++g b" := (app (A:=instruction) a b) (at level 49, right associativity). Notation "a @@ b" := (app a b) (at level 49, right associativity). -(** Smart constructors for arithmetic operations involving - a 32-bit or 64-bit integer constant. Depending on whether the - constant fits in 12 bits or not, one or several instructions - are generated as required to perform the operation - and prepended to the given instruction sequence [k]. *) - Definition loadimm32 (r: ireg) (n: int) := match make_immed32 n with | Imm32_single imm => Pmake r imm @@ -92,10 +81,6 @@ Definition orimm32 := opimm32 Porw Poriw. Definition norimm32 := opimm32 Pnorw Pnoriw. Definition xorimm32 := opimm32 Pxorw Pxoriw. Definition nxorimm32 := opimm32 Pnxorw Pnxoriw. -(* -Definition sltimm32 := opimm32 Psltw Psltiw. -Definition sltuimm32 := opimm32 Psltuw Psltiuw. -*) Definition loadimm64 (r: ireg) (n: int64) := match make_immed64 n with @@ -118,11 +103,6 @@ Definition norimm64 := opimm64 Pnorl Pnoril. Definition nandimm64 := opimm64 Pnandl Pnandil. Definition nxorimm64 := opimm64 Pnxorl Pnxoril. -(* -Definition sltimm64 := opimm64 Psltl Psltil. -Definition sltuimm64 := opimm64 Psltul Psltiul. -*) - Definition addptrofs (rd rs: ireg) (n: ptrofs) := if Ptrofs.eq_dec n Ptrofs.zero then Pmv rd rs @@ -170,19 +150,6 @@ Definition transl_opt_compuimm transl_compi c Unsigned r1 n lbl k . -(* Definition transl_opt_compuimm - (n: int) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction := - loadimm32 RTMP n ::g (transl_comp c Unsigned r1 RTMP lbl k). *) - -(* match select_comp n c with - | Some Ceq => Pcbu BTweqz r1 lbl ::g k - | Some Cne => Pcbu BTwnez r1 lbl ::g k - | Some _ => nil (* Never happens *) - | None => loadimm32 RTMP n ::g (transl_comp c Unsigned r1 RTMP lbl k) - end - . - *) - Definition select_compl (n: int64) (c: comparison) : option comparison := if Int64.eq n Int64.zero then match c with @@ -334,6 +301,75 @@ Definition transl_cond_notfloat64 (cmp: comparison) (rd r1 r2: ireg) (k: bcode) | Reversed ft => Pfcompl ft rd r2 r1 ::i k end. + +(* CoMPare Unsigned Words to Zero *) +Definition btest_for_cmpuwz (c: comparison) := + match c with + | Cne => OK BTwnez + | Ceq => OK BTweqz + | Clt => Error (msg "btest_for_compuwz: Clt") + | Cge => Error (msg "btest_for_compuwz: Cge") + | Cle => OK BTweqz + | Cgt => OK BTwnez + end. + +(* CoMPare Unsigned Words to Zero *) +Definition btest_for_cmpudz (c: comparison) := + match c with + | Cne => OK BTdnez + | Ceq => OK BTdeqz + | Clt => Error (msg "btest_for_compudz: Clt") + | Cge => Error (msg "btest_for_compudz: Cge") + | Cle => OK BTdeqz + | Cgt => OK BTdnez + end. + +Definition conditional_move (cond0 : condition0) (rc rd rs : ireg) : + res basic := + if ireg_eq rd rs + then OK Pnop + else + (match cond0 with + | Ccomp0 cmp => + OK (PArith (Pcmove (btest_for_cmpswz cmp) rd rc rs)) + | Ccompu0 cmp => + do bt <- btest_for_cmpuwz cmp; + OK (PArith (Pcmoveu bt rd rc rs)) + | Ccompl0 cmp => + OK (PArith (Pcmove (btest_for_cmpsdz cmp) rd rc rs)) + | Ccomplu0 cmp => + do bt <- btest_for_cmpudz cmp; + OK (PArith (Pcmoveu bt rd rc rs)) + end). + +Definition conditional_move_imm32 (cond0 : condition0) (rc rd : ireg) (imm : int) : res basic := + match cond0 with + | Ccomp0 cmp => + OK (PArith (Pcmoveiw (btest_for_cmpswz cmp) rd rc imm)) + | Ccompu0 cmp => + do bt <- btest_for_cmpuwz cmp; + OK (PArith (Pcmoveuiw bt rd rc imm)) + | Ccompl0 cmp => + OK (PArith (Pcmoveiw (btest_for_cmpsdz cmp) rd rc imm)) + | Ccomplu0 cmp => + do bt <- btest_for_cmpudz cmp; + OK (PArith (Pcmoveuiw bt rd rc imm)) + end. + +Definition conditional_move_imm64 (cond0 : condition0) (rc rd : ireg) (imm : int64) : res basic := + match cond0 with + | Ccomp0 cmp => + OK (PArith (Pcmoveil (btest_for_cmpswz cmp) rd rc imm)) + | Ccompu0 cmp => + do bt <- btest_for_cmpuwz cmp; + OK (PArith (Pcmoveuil bt rd rc imm)) + | Ccompl0 cmp => + OK (PArith (Pcmoveil (btest_for_cmpsdz cmp) rd rc imm)) + | Ccomplu0 cmp => + do bt <- btest_for_cmpudz cmp; + OK (PArith (Pcmoveuil bt rd rc imm)) + end. + Definition transl_cond_op (cond: condition) (rd: ireg) (args: list mreg) (k: bcode) := match cond, args with @@ -377,28 +413,6 @@ Definition transl_cond_op Error(msg "Asmblockgen.transl_cond_op") end. -(* CoMPare Unsigned Words to Zero *) -Definition btest_for_cmpuwz (c: comparison) := - match c with - | Cne => OK BTwnez - | Ceq => OK BTweqz - | Clt => Error (msg "btest_for_compuwz: Clt") - | Cge => Error (msg "btest_for_compuwz: Cge") - | Cle => Error (msg "btest_for_compuwz: Cle") - | Cgt => Error (msg "btest_for_compuwz: Cgt") - end. - -(* CoMPare Unsigned Words to Zero *) -Definition btest_for_cmpudz (c: comparison) := - match c with - | Cne => OK BTdnez - | Ceq => OK BTdeqz - | Clt => Error (msg "btest_for_compudz: Clt") - | Cge => Error (msg "btest_for_compudz: Cge") - | Cle => Error (msg "btest_for_compudz: Cle") - | Cgt => Error (msg "btest_for_compudz: Cgt") - end. - (** Translation of the arithmetic operation [r <- op(args)]. The corresponding instructions are prepended to [k]. *) @@ -443,12 +457,33 @@ Definition transl_op | Oaddimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (addimm32 rd rs n ::i k) + | Oaddx shift, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Paddxw shift rd rs1 rs2 ::i k) + | Oaddximm shift n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Paddxiw shift rd rs n ::i k) + | Oaddxl shift, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Paddxl shift rd rs1 rs2 ::i k) + | Oaddxlimm shift n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Paddxil shift rd rs n ::i k) | Oneg, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Pnegw rd rs ::i k) | Osub, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Psubw rd rs1 rs2 ::i k) + | Orevsubimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Prevsubiw rd rs n ::i k) + | Orevsubx shift, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Prevsubxw shift rd rs1 rs2 ::i k) + | Orevsubximm shift n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Prevsubxiw shift rd rs n ::i k) | Omul, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pmulw rd rs1 rs2 ::i k) @@ -543,6 +578,12 @@ Definition transl_op do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (Pmaddiw r1 r2 n ::i k) + | Omsub, a1 :: a2 :: a3 :: nil => + assertion (mreg_eq a1 res); + do r1 <- ireg_of a1; + do r2 <- ireg_of a2; + do r3 <- ireg_of a3; + OK (Pmsubw r1 r2 r3 ::i k) (* [Omakelong], [Ohighlong] should not occur *) | Olowlong, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; @@ -567,6 +608,15 @@ Definition transl_op | Osubl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Psubl rd rs1 rs2 ::i k) + | Orevsubxl shift, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Prevsubxl shift rd rs1 rs2 ::i k) + | Orevsublimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Prevsubil rd rs n ::i k) + | Orevsubxlimm shift n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Prevsubxil shift rd rs n ::i k) | Omull, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pmull rd rs1 rs2 ::i k) @@ -662,6 +712,12 @@ Definition transl_op do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (Pmaddil r1 r2 n ::i k) + | Omsubl, a1 :: a2 :: a3 :: nil => + assertion (mreg_eq a1 res); + do r1 <- ireg_of a1; + do r2 <- ireg_of a2; + do r3 <- ireg_of a3; + OK (Pmsubl r1 r2 r3 ::i k) | Oabsf, a1 :: nil => do rd <- freg_of res; do rs <- freg_of a1; OK (Pfabsd rd rs ::i k) @@ -686,12 +742,52 @@ Definition transl_op | Omulfs, a1 :: a2 :: nil => do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; OK (Pfmulw rd rs1 rs2 ::i k) + | Ominf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfmind rd rs1 rs2 ::i k) + | Ominfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfminw rd rs1 rs2 ::i k) + | Omaxf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfmaxd rd rs1 rs2 ::i k) + | Omaxfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfmaxw rd rs1 rs2 ::i k) | Onegf, a1 :: nil => do rd <- freg_of res; do rs <- freg_of a1; OK (Pfnegd rd rs ::i k) | Onegfs, a1 :: nil => do rd <- freg_of res; do rs <- freg_of a1; OK (Pfnegw rd rs ::i k) + | Oinvfs, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfinvw rd rs ::i k) + + | Ofmaddf, a1 :: a2 :: a3 :: nil => + assertion (mreg_eq a1 res); + do rs1 <- freg_of a1; + do rs2 <- freg_of a2; + do rs3 <- freg_of a3; + OK (Pfmaddfl rs1 rs2 rs3 ::i k) + | Ofmaddfs, a1 :: a2 :: a3 :: nil => + assertion (mreg_eq a1 res); + do rs1 <- freg_of a1; + do rs2 <- freg_of a2; + do rs3 <- freg_of a3; + OK (Pfmaddfw rs1 rs2 rs3 ::i k) + | Ofmsubf, a1 :: a2 :: a3 :: nil => + assertion (mreg_eq a1 res); + do rs1 <- freg_of a1; + do rs2 <- freg_of a2; + do rs3 <- freg_of a3; + OK (Pfmsubfl rs1 rs2 rs3 ::i k) + | Ofmsubfs, a1 :: a2 :: a3 :: nil => + assertion (mreg_eq a1 res); + do rs1 <- freg_of a1; + do rs2 <- freg_of a2; + do rs3 <- freg_of a3; + OK (Pfmsubfw rs1 rs2 rs3 ::i k) | Osingleofint, a1 :: nil => do rd <- freg_of res; do rs <- ireg_of a1; @@ -742,31 +838,10 @@ Definition transl_op | Olonguofsingle , _ => Error (msg "Asmblockgen.transl_op: Olonguofsingle") - | Ocmp cmp, _ => do rd <- ireg_of res; transl_cond_op cmp rd args k - | Oselect cond, a0 :: a1 :: aS :: nil - | Oselectl cond, a0 :: a1 :: aS :: nil - | Oselectf cond, a0 :: a1 :: aS :: nil - | Oselectfs cond, a0 :: a1 :: aS :: nil => - assertion (mreg_eq a0 res); - do r0 <- ireg_of a0; - do r1 <- ireg_of a1; - do rS <- ireg_of aS; - (match cond with - | Ccomp0 cmp => - OK (Pcmove (btest_for_cmpswz cmp) r0 rS r1 ::i k) - | Ccompu0 cmp => - do bt <- btest_for_cmpuwz cmp; - OK (Pcmoveu bt r0 rS r1 ::i k) - | Ccompl0 cmp => - OK (Pcmove (btest_for_cmpsdz cmp) r0 rS r1 ::i k) - | Ccomplu0 cmp => - do bt <- btest_for_cmpudz cmp; - OK (Pcmoveu bt r0 rS r1 ::i k) - end) | Oextfz stop start, a1 :: nil => assertion (ExtValues.is_bitfield stop start); @@ -800,6 +875,29 @@ Definition transl_op do rd <- ireg_of res; do rs <- ireg_of a1; OK (Pinsfl stop start rd rs ::i k) + | Osel cond0 ty, aT :: aF :: aC :: nil => + assertion (mreg_eq aT res); + do rT <- ireg_of aT; + do rF <- ireg_of aF; + do rC <- ireg_of aC; + do op <- conditional_move (negate_condition0 cond0) rC rT rF; + OK (op ::i k) + + | Oselimm cond0 imm, aT :: aC :: nil => + assertion (mreg_eq aT res); + do rT <- ireg_of aT; + do rC <- ireg_of aC; + do op <- conditional_move_imm32 (negate_condition0 cond0) rC rT imm; + OK (op ::i k) + + + | Osellimm cond0 imm, aT :: aC :: nil => + assertion (mreg_eq aT res); + do rT <- ireg_of aT; + do rC <- ireg_of aC; + do op <- conditional_move_imm64 (negate_condition0 cond0) rC rT imm; + OK (op ::i k) + | _, _ => Error(msg "Asmgenblock.transl_op") end. @@ -816,12 +914,12 @@ end. Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: bcode) := match ty, preg_of dst with - | Tint, IR rd => OK (indexed_memory_access (PLoadRRO Plw rd) base ofs ::i k) - | Tlong, IR rd => OK (indexed_memory_access (PLoadRRO Pld rd) base ofs ::i k) - | Tsingle, IR rd => OK (indexed_memory_access (PLoadRRO Pfls rd) base ofs ::i k) - | Tfloat, IR rd => OK (indexed_memory_access (PLoadRRO Pfld rd) base ofs ::i k) - | Tany32, IR rd => OK (indexed_memory_access (PLoadRRO Plw_a rd) base ofs ::i k) - | Tany64, IR rd => OK (indexed_memory_access (PLoadRRO Pld_a rd) base ofs ::i k) + | Tint, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Plw rd) base ofs ::i k) + | Tlong, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Pld rd) base ofs ::i k) + | Tsingle, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Pfls rd) base ofs ::i k) + | Tfloat, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Pfld rd) base ofs ::i k) + | Tany32, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Plw_a rd) base ofs ::i k) + | Tany64, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Pld_a rd) base ofs ::i k) | _, _ => Error (msg "Asmblockgen.loadind") end. @@ -837,7 +935,7 @@ Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: bcode) end. Definition loadind_ptr (base: ireg) (ofs: ptrofs) (dst: ireg) := - indexed_memory_access (PLoadRRO Pld dst) base ofs. + indexed_memory_access (PLoadRRO TRAP Pld dst) base ofs. Definition storeind_ptr (src: ireg) (base: ireg) (ofs: ptrofs) := indexed_memory_access (PStoreRRO Psd src) base ofs. @@ -897,27 +995,28 @@ Definition chunk2load (chunk: memory_chunk) := | Many64 => Pld_a end. -Definition transl_load_rro (chunk: memory_chunk) (addr: addressing) +Definition transl_load_rro (trap: trapping_mode) (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg) (k: bcode) : res bcode := do r <- ireg_of dst; - transl_memory_access (PLoadRRO (chunk2load chunk) r) addr args k. + transl_memory_access (PLoadRRO trap (chunk2load chunk) r) addr args k. -Definition transl_load_rrr (chunk: memory_chunk) (addr: addressing) +Definition transl_load_rrr (trap: trapping_mode) (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg) (k: bcode) : res bcode := do r <- ireg_of dst; - transl_memory_access2 (PLoadRRR (chunk2load chunk) r) addr args k. + transl_memory_access2 (PLoadRRR trap (chunk2load chunk) r) addr args k. -Definition transl_load_rrrXS (chunk: memory_chunk) (scale : Z) +Definition transl_load_rrrXS (trap: trapping_mode) (chunk: memory_chunk) (scale : Z) (args: list mreg) (dst: mreg) (k: bcode) : res bcode := do r <- ireg_of dst; - transl_memory_access2XS chunk (PLoadRRRXS (chunk2load chunk) r) scale args k. + transl_memory_access2XS chunk (PLoadRRRXS trap (chunk2load chunk) r) scale args k. -Definition transl_load (chunk: memory_chunk) (addr: addressing) +Definition transl_load (trap : trapping_mode) + (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg) (k: bcode) : res bcode := match addr with - | Aindexed2XS scale => transl_load_rrrXS chunk scale args dst k - | Aindexed2 => transl_load_rrr chunk addr args dst k - | _ => transl_load_rro chunk addr args dst k + | Aindexed2XS scale => transl_load_rrrXS trap chunk scale args dst k + | Aindexed2 => transl_load_rrr trap chunk addr args dst k + | _ => transl_load_rro trap chunk addr args dst k end. Definition chunk2store (chunk: memory_chunk) := @@ -961,7 +1060,7 @@ Definition make_epilogue (f: Machblock.function) (k: code) := (loadind_ptr SP f.(fn_retaddr_ofs) GPRA) ::g Pset RA GPRA ::g Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) ::g k. -(** Translation of a Mach instruction. *) +(** Translation of a Machblock instruction. *) Definition transl_instr_basic (f: Machblock.function) (i: Machblock.basic_inst) (ep: bool) (k: bcode) := @@ -977,8 +1076,8 @@ Definition transl_instr_basic (f: Machblock.function) (i: Machblock.basic_inst) else (loadind_ptr SP f.(fn_link_ofs) FP) ::i c) | MBop op args res => transl_op op args res k - | MBload chunk addr args dst => - transl_load chunk addr args dst k + | MBload trap chunk addr args dst => + transl_load trap chunk addr args dst k | MBstore chunk addr args src => transl_store chunk addr args src k end. @@ -1005,32 +1104,25 @@ Definition transl_instr_control (f: Machblock.function) (oi: option Machblock.co transl_cbranch cond args lbl nil | MBreturn => OK (make_epilogue f (Pret ::g nil)) - (*OK (make_epilogue f (Pj_r RA f.(Mach.fn_sig) :: k))*) | MBjumptable arg tbl => do r <- ireg_of arg; OK (Pjumptable r tbl ::g nil) end end. -(* TODO - dans l'idée, transl_instr_control renvoie une liste d'instructions sous la forme : - * transl_instr_control _ _ _ = lb ++ (ctl :: nil), où lb est une liste de basics, ctl est un control_inst - - Il faut arriver à exprimer cet aspect là ; extraire le lb, le rajouter dans le body ; et extraire le ctl - qu'on met dans le exit -*) - (** Translation of a code sequence *) Definition fp_is_parent (before: bool) (i: Machblock.basic_inst) : bool := match i with + | MBgetstack ofs ty dst => before && negb (mreg_eq dst MFP) | MBsetstack src ofs ty => before | MBgetparam ofs ty dst => negb (mreg_eq dst MFP) | MBop op args res => before && negb (mreg_eq res MFP) - | _ => false + | MBload trapping_mode chunk addr args dst => before && negb (mreg_eq dst MFP) + | MBstore chunk addr args res => before end. -(** This is the naive definition that we no longer use because it - is not tail-recursive. It is kept as specification. *) +(** This is the naive definition, which is not tail-recursive unlike the other backends *) Fixpoint transl_basic_code (f: Machblock.function) (il: list Machblock.basic_inst) (it1p: bool) := match il with @@ -1056,20 +1148,11 @@ Definition transl_basic_code' (f: Machblock.function) (il: list Machblock.basic_ transl_basic_rec f il it1p (fun c => OK c). *) (** Translation of a whole function. Note that we must check - that the generated code contains less than [2^32] instructions, + that the generated code contains less than [2^64] instructions, otherwise the offset part of the [PC] code pointer could wrap around, leading to incorrect executions. *) -(* Local Obligation Tactic := bblock_auto_correct. *) - -(* Program Definition gen_bblock_noctl (hd: list label) (c: list basic) := - match c with - | nil => {| header := hd; body := Pnop::nil; exit := None |} - | i::c => {| header := hd; body := i::c; exit := None |} - end. - *) - -(** Can generate two bblocks if the ctl is a PExpand (since the PExpand must be alone in its block) *) +(* gen_bblocks can generate two bblocks if the ctl is a PExpand (since the PExpand must be alone in its block) *) Program Definition gen_bblocks (hd: list label) (c: list basic) (ctl: list instruction) := match (extract_ctl ctl) with | None => @@ -1077,7 +1160,6 @@ Program Definition gen_bblocks (hd: list label) (c: list basic) (ctl: list instr | nil => {| header := hd; body := Pnop::nil; exit := None |} :: nil | i::c => {| header := hd; body := ((i::c) ++ extract_basic ctl); exit := None |} :: nil end -(* gen_bblock_noctl hd (c ++ (extract_basic ctl)) :: nil *) | Some (PExpand (Pbuiltin ef args res)) => match c with | nil => {| header := hd; body := nil; exit := Some (PExpand (Pbuiltin ef args res)) |} :: nil diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index c44ef3ff..1a427112 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1,1797 +1,1804 @@ -(* *********************************************************************)
-(* *)
-(* The Compcert verified compiler *)
-(* *)
-(* Xavier Leroy, INRIA Paris-Rocquencourt *)
-(* *)
-(* Copyright Institut National de Recherche en Informatique et en *)
-(* Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the INRIA Non-Commercial License Agreement. *)
-(* *)
-(* *********************************************************************)
-
-(** Correctness proof for RISC-V generation: main proof. *)
-
-Require Import Coqlib Errors.
-Require Import Integers Floats AST Linking.
-Require Import Values Memory Events Globalenvs Smallstep.
-Require Import Op Locations Machblock Conventions Asmblock.
-Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1.
-Require Import Axioms.
-
-Module MB := Machblock.
-Module AB := Asmvliw.
-
-Definition match_prog (p: Machblock.program) (tp: Asmvliw.program) :=
- match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp.
-
-Lemma transf_program_match:
- forall p tp, transf_program p = OK tp -> match_prog p tp.
-Proof.
- intros. eapply match_transform_partial_program; eauto.
-Qed.
-
-Section PRESERVATION.
-
-Variable prog: Machblock.program.
-Variable tprog: Asmvliw.program.
-Hypothesis TRANSF: match_prog prog tprog.
-Let ge := Genv.globalenv prog.
-Let tge := Genv.globalenv tprog.
-
-Lemma symbols_preserved:
- forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
-Proof (Genv.find_symbol_match TRANSF).
-
-Lemma senv_preserved:
- Senv.equiv ge tge.
-Proof (Genv.senv_match TRANSF).
-
-
-Lemma functions_translated:
- forall b f,
- Genv.find_funct_ptr ge b = Some f ->
- exists tf,
- Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf.
-Proof (Genv.find_funct_ptr_transf_partial TRANSF).
-
-Lemma functions_transl:
- forall fb f tf,
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- transf_function f = OK tf ->
- Genv.find_funct_ptr tge fb = Some (Internal tf).
-Proof.
- intros. exploit functions_translated; eauto. intros [tf' [A B]].
- monadInv B. rewrite H0 in EQ; inv EQ; auto.
-Qed.
-
-(** * Properties of control flow *)
-
-Lemma transf_function_no_overflow:
- forall f tf,
- transf_function f = OK tf -> size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned.
-Proof.
- intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0.
- omega.
-Qed.
-
-(** The following lemmas show that the translation from Mach to Asm
- preserves labels, in the sense that the following diagram commutes:
-<<
- translation
- Mach code ------------------------ Asm instr sequence
- | |
- | Mach.find_label lbl find_label lbl |
- | |
- v v
- Mach code tail ------------------- Asm instr seq tail
- translation
->>
- The proof demands many boring lemmas showing that Asm constructor
- functions do not introduce new labels.
-*)
-
-Section TRANSL_LABEL.
-
-Lemma gen_bblocks_label:
- forall hd bdy ex tbb tc,
- gen_bblocks hd bdy ex = tbb::tc ->
- header tbb = hd.
-Proof.
- intros until tc. intros GENB. unfold gen_bblocks in GENB.
- destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy.
- all: inv GENB; simpl; auto.
-Qed.
-
-Lemma gen_bblocks_label2:
- forall hd bdy ex tbb1 tbb2,
- gen_bblocks hd bdy ex = tbb1::tbb2::nil ->
- header tbb2 = nil.
-Proof.
- intros until tbb2. intros GENB. unfold gen_bblocks in GENB.
- destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy.
- all: inv GENB; simpl; auto.
-Qed.
-
-Lemma in_dec_transl:
- forall lbl hd,
- (if in_dec lbl hd then true else false) = (if MB.in_dec lbl hd then true else false).
-Proof.
- intros. destruct (in_dec lbl hd), (MB.in_dec lbl hd). all: tauto.
-Qed.
-
-Lemma transl_is_label:
- forall lbl bb tbb f ep tc,
- transl_block f bb ep = OK (tbb::tc) ->
- is_label lbl tbb = MB.is_label lbl bb.
-Proof.
- intros until tc. intros TLB.
- destruct tbb as [thd tbdy tex]; simpl in *.
- monadInv TLB.
- unfold is_label. simpl.
- apply gen_bblocks_label in H0. simpl in H0. subst.
- rewrite in_dec_transl. auto.
-Qed.
-
-Lemma transl_is_label_false2:
- forall lbl bb f ep tbb1 tbb2,
- transl_block f bb ep = OK (tbb1::tbb2::nil) ->
- is_label lbl tbb2 = false.
-Proof.
- intros until tbb2. intros TLB.
- destruct tbb2 as [thd tbdy tex]; simpl in *.
- monadInv TLB. apply gen_bblocks_label2 in H0. simpl in H0. subst.
- apply is_label_correct_false. simpl. auto.
-Qed.
-
-Lemma transl_is_label2:
- forall f bb ep tbb1 tbb2 lbl,
- transl_block f bb ep = OK (tbb1::tbb2::nil) ->
- is_label lbl tbb1 = MB.is_label lbl bb
- /\ is_label lbl tbb2 = false.
-Proof.
- intros. split. eapply transl_is_label; eauto. eapply transl_is_label_false2; eauto.
-Qed.
-
-Lemma transl_block_nonil:
- forall f c ep tc,
- transl_block f c ep = OK tc ->
- tc <> nil.
-Proof.
- intros. monadInv H. unfold gen_bblocks.
- destruct (extract_ctl x0); try destruct c0; try destruct x; try destruct i.
- all: discriminate.
-Qed.
-
-Lemma transl_block_limit: forall f bb ep tbb1 tbb2 tbb3 tc,
- ~transl_block f bb ep = OK (tbb1 :: tbb2 :: tbb3 :: tc).
-Proof.
- intros. intro. monadInv H.
- unfold gen_bblocks in H0.
- destruct (extract_ctl x0); try destruct x; try destruct c; try destruct i.
- all: discriminate.
-Qed.
-
-Lemma find_label_transl_false:
- forall x f lbl bb ep x',
- transl_block f bb ep = OK x ->
- MB.is_label lbl bb = false ->
- find_label lbl (x++x') = find_label lbl x'.
-Proof.
- intros until x'. intros TLB MBis; simpl; auto.
- destruct x as [|x0 x1]; simpl; auto.
- destruct x1 as [|x1 x2]; simpl; auto.
- - erewrite <- transl_is_label in MBis; eauto. rewrite MBis. auto.
- - destruct x2 as [|x2 x3]; simpl; auto.
- + erewrite <- transl_is_label in MBis; eauto. rewrite MBis.
- erewrite transl_is_label_false2; eauto.
- + apply transl_block_limit in TLB. destruct TLB.
-Qed.
-
-Lemma transl_blocks_label:
- forall lbl f c tc ep,
- transl_blocks f c ep = OK tc ->
- match MB.find_label lbl c with
- | None => find_label lbl tc = None
- | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_blocks f c' false = OK tc'
- end.
-Proof.
- induction c; simpl; intros.
- inv H. auto.
- monadInv H.
- destruct (MB.is_label lbl a) eqn:MBis.
- - destruct x as [|tbb tc]. { apply transl_block_nonil in EQ. contradiction. }
- simpl find_label. exploit transl_is_label; eauto. intros ABis. rewrite MBis in ABis.
- rewrite ABis.
- eexists. eexists. split; eauto. simpl transl_blocks.
- assert (MB.header a <> nil).
- { apply MB.is_label_correct_true in MBis.
- destruct (MB.header a). contradiction. discriminate. }
- destruct (MB.header a); try contradiction.
- rewrite EQ. simpl. rewrite EQ1. simpl. auto.
- - apply IHc in EQ1. destruct (MB.find_label lbl c).
- + destruct EQ1 as (tc' & FIND & TLBS). exists tc'; eexists; auto.
- erewrite find_label_transl_false; eauto.
- + erewrite find_label_transl_false; eauto.
-Qed.
-
-Lemma find_label_nil:
- forall bb lbl c,
- header bb = nil ->
- find_label lbl (bb::c) = find_label lbl c.
-Proof.
- intros. destruct bb as [hd bdy ex]; simpl in *. subst.
- assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false).
- { erewrite <- is_label_correct_false. simpl. auto. }
- rewrite H. auto.
-Qed.
-
-Lemma transl_find_label:
- forall lbl f tf,
- transf_function f = OK tf ->
- match MB.find_label lbl f.(MB.fn_code) with
- | None => find_label lbl tf.(fn_blocks) = None
- | Some c => exists tc, find_label lbl tf.(fn_blocks) = Some tc /\ transl_blocks f c false = OK tc
- end.
-Proof.
- intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks x))); inv EQ0. clear g.
- monadInv EQ. unfold make_prologue. simpl fn_blocks. repeat (rewrite find_label_nil); simpl; auto.
- eapply transl_blocks_label; eauto.
-Qed.
-
-End TRANSL_LABEL.
-
-(** A valid branch in a piece of Mach code translates to a valid ``go to''
- transition in the generated Asm code. *)
-
-Lemma find_label_goto_label:
- forall f tf lbl rs m c' b ofs,
- Genv.find_funct_ptr ge b = Some (Internal f) ->
- transf_function f = OK tf ->
- rs PC = Vptr b ofs ->
- MB.find_label lbl f.(MB.fn_code) = Some c' ->
- exists tc', exists rs',
- goto_label tf lbl rs m = Next rs' m
- /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc'
- /\ forall r, r <> PC -> rs'#r = rs#r.
-Proof.
- intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2.
- intros (tc & A & B).
- exploit label_pos_code_tail; eauto. instantiate (1 := 0).
- intros [pos' [P [Q R]]].
- exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))).
- split. unfold goto_label. unfold par_goto_label. rewrite P. rewrite H1. auto.
- split. rewrite Pregmap.gss. constructor; auto.
- rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q.
- auto. omega.
- generalize (transf_function_no_overflow _ _ H0). omega.
- intros. apply Pregmap.gso; auto.
-Qed.
-
-(** Existence of return addresses *)
-
-(* NB: the hypothesis in comment on [b] is not needed in the proof !
-*)
-Lemma return_address_exists:
- forall b f (* sg ros *) c, (* b.(MB.exit) = Some (MBcall sg ros) -> *) is_tail (b :: c) f.(MB.fn_code) ->
- exists ra, return_address_offset f c ra.
-Proof.
- intros. eapply Asmblockgenproof0.return_address_exists; eauto.
-
-- intros. monadInv H0.
- destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. monadInv EQ. simpl.
-(* rewrite transl_code'_transl_code in EQ0. *)
- exists x; exists true; split; auto. (* unfold fn_code. *)
- repeat constructor.
- - exact transf_function_no_overflow.
-Qed.
-
-(** * Proof of semantic preservation *)
-
-(** Semantic preservation is proved using simulation diagrams
- of the following form.
-<<
- st1 --------------- st2
- | |
- t| *|t
- | |
- v v
- st1'--------------- st2'
->>
- The invariant is the [match_states] predicate below, which includes:
-- The Asm code pointed by the PC register is the translation of
- the current Mach code sequence.
-- Mach register values and Asm register values agree.
-*)
-
-(** We need to show that, in the simulation diagram, we cannot
- take infinitely many Mach transitions that correspond to zero
- transitions on the Asm side. Actually, all Mach transitions
- correspond to at least one Asm transition, except the
- transition from [Machsem.Returnstate] to [Machsem.State].
- So, the following integer measure will suffice to rule out
- the unwanted behaviour. *)
-
-
-Remark preg_of_not_FP: forall r, negb (mreg_eq r MFP) = true -> IR FP <> preg_of r.
-Proof.
- intros. change (IR FP) with (preg_of MFP). red; intros.
- exploit preg_of_injective; eauto. intros; subst r; discriminate.
-Qed.
-
-Inductive match_states: Machblock.state -> Asmvliw.state -> Prop :=
- | match_states_intro:
- forall s fb sp c ep ms m m' rs f tf tc
- (STACKS: match_stack ge s)
- (FIND: Genv.find_funct_ptr ge fb = Some (Internal f))
- (MEXT: Mem.extends m m')
- (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc)
- (AG: agree ms sp rs)
- (DXP: ep = true -> rs#FP = parent_sp s),
- match_states (Machblock.State s fb sp c ms m)
- (Asmvliw.State rs m')
- | match_states_call:
- forall s fb ms m m' rs
- (STACKS: match_stack ge s)
- (MEXT: Mem.extends m m')
- (AG: agree ms (parent_sp s) rs)
- (ATPC: rs PC = Vptr fb Ptrofs.zero)
- (ATLR: rs RA = parent_ra s),
- match_states (Machblock.Callstate s fb ms m)
- (Asmvliw.State rs m')
- | match_states_return:
- forall s ms m m' rs
- (STACKS: match_stack ge s)
- (MEXT: Mem.extends m m')
- (AG: agree ms (parent_sp s) rs)
- (ATPC: rs PC = parent_ra s),
- match_states (Machblock.Returnstate s ms m)
- (Asmvliw.State rs m').
-
-Record codestate :=
- Codestate { pstate: state;
- pheader: list label;
- pbody1: list basic;
- pbody2: list basic;
- pctl: option control;
- fpok: bool;
- rem: list AB.bblock;
- cur: option bblock }.
-
-(* | Codestate: state -> list AB.bblock -> option bblock -> codestate. *)
-
-Inductive match_codestate fb: Machblock.state -> codestate -> Prop :=
- | match_codestate_intro:
- forall s sp ms m rs0 m0 f tc ep c bb tbb tbc tbi
- (STACKS: match_stack ge s)
- (FIND: Genv.find_funct_ptr ge fb = Some (Internal f))
- (MEXT: Mem.extends m m0)
- (TBC: transl_basic_code f (MB.body bb) (if MB.header bb then ep else false) = OK tbc)
- (TIC: transl_instr_control f (MB.exit bb) = OK tbi)
- (TBLS: transl_blocks f c false = OK tc)
-(* (TRANS: transl_blocks f (bb::c) ep = OK (tbb::tc)) *)
- (AG: agree ms sp rs0)
- (DXP: (if MB.header bb then ep else false) = true -> rs0#FP = parent_sp s)
- ,
- match_codestate fb (Machblock.State s fb sp (bb::c) ms m)
- {| pstate := (Asmvliw.State rs0 m0);
- pheader := (MB.header bb);
- pbody1 := tbc;
- pbody2 := (extract_basic tbi);
- pctl := extract_ctl tbi;
- fpok := ep;
- rem := tc;
- cur := Some tbb
- |}
-.
-
-Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop :=
- | match_asmstate_some:
- forall rs f tf tc m tbb ofs ep tbdy tex lhd
- (FIND: Genv.find_funct_ptr ge fb = Some (Internal f))
- (TRANSF: transf_function f = OK tf)
- (PCeq: rs PC = Vptr fb ofs)
- (TAIL: code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (tbb::tc))
-(* (HDROK: header tbb = lhd) *)
- ,
- match_asmstate fb
- {| pstate := (Asmvliw.State rs m);
- pheader := lhd;
- pbody1 := tbdy;
- pbody2 := extract_basic tex;
- pctl := extract_ctl tex;
- fpok := ep;
- rem := tc;
- cur := Some tbb |}
- (Asmvliw.State rs m)
-.
-
-Ltac exploreInst :=
- repeat match goal with
- | [ H : match ?var with | _ => _ end = _ |- _ ] => destruct var
- | [ H : OK _ = OK _ |- _ ] => monadInv H
- | [ |- context[if ?b then _ else _] ] => destruct b
- | [ |- context[match ?m with | _ => _ end] ] => destruct m
- | [ |- context[match ?m as _ return _ with | _ => _ end]] => destruct m
- | [ H : bind _ _ = OK _ |- _ ] => monadInv H
- | [ H : Error _ = OK _ |- _ ] => inversion H
- end.
-
-Lemma transl_blocks_nonil:
- forall f bb c tc ep,
- transl_blocks f (bb::c) ep = OK tc ->
- exists tbb tc', tc = tbb :: tc'.
-Proof.
- intros until ep. intros TLBS. monadInv TLBS. monadInv EQ. unfold gen_bblocks.
- destruct (extract_ctl x2).
- - destruct c0; destruct i; simpl; eauto. destruct x1; simpl; eauto.
- - destruct x1; simpl; eauto.
-Qed.
-
-Lemma no_builtin_preserved:
- forall f ex x2,
- (forall ef args res, ex <> Some (MBbuiltin ef args res)) ->
- transl_instr_control f ex = OK x2 ->
- (exists i, extract_ctl x2 = Some (PCtlFlow i))
- \/ extract_ctl x2 = None.
-Proof.
- intros until x2. intros Hbuiltin TIC.
- destruct ex.
- - destruct c.
- (* MBcall *)
- + simpl in TIC. exploreInst; simpl; eauto.
- (* MBtailcall *)
- + simpl in TIC. exploreInst; simpl; eauto.
- (* MBbuiltin *)
- + assert (H: Some (MBbuiltin e l b) <> Some (MBbuiltin e l b)).
- apply Hbuiltin. contradict H; auto.
- (* MBgoto *)
- + simpl in TIC. exploreInst; simpl; eauto.
- (* MBcond *)
- + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; simpl; eauto.
- * unfold transl_opt_compuimm. exploreInst; simpl; eauto.
- * unfold transl_opt_compluimm. exploreInst; simpl; eauto.
- * unfold transl_comp_float64. exploreInst; simpl; eauto.
- * unfold transl_comp_notfloat64. exploreInst; simpl; eauto.
- * unfold transl_comp_float32. exploreInst; simpl; eauto.
- * unfold transl_comp_notfloat32. exploreInst; simpl; eauto.
- (* MBjumptable *)
- + simpl in TIC. exploreInst; simpl; eauto.
- (* MBreturn *)
- + simpl in TIC. monadInv TIC. simpl. eauto.
- - monadInv TIC. simpl; auto.
-Qed.
-
-Lemma transl_blocks_distrib:
- forall c f bb tbb tc ep,
- transl_blocks f (bb::c) ep = OK (tbb::tc)
- -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res))
- -> transl_block f bb (if MB.header bb then ep else false) = OK (tbb :: nil)
- /\ transl_blocks f c false = OK tc.
-Proof.
- intros until ep. intros TLBS Hbuiltin.
- destruct bb as [hd bdy ex].
- monadInv TLBS. monadInv EQ.
- exploit no_builtin_preserved; eauto. intros Hectl. destruct Hectl.
- - destruct H as [i Hectl].
- unfold gen_bblocks in H0. rewrite Hectl in H0. inv H0.
- simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl.
- unfold gen_bblocks. rewrite Hectl. auto.
- - unfold gen_bblocks in H0. rewrite H in H0.
- destruct x1 as [|bi x1].
- + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl.
- unfold gen_bblocks. rewrite H. auto.
- + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl.
- unfold gen_bblocks. rewrite H. auto.
-Qed.
-
-Lemma gen_bblocks_nobuiltin:
- forall thd tbdy tex tbb,
- (tbdy <> nil \/ extract_ctl tex <> None) ->
- (forall ef args res, extract_ctl tex <> Some (PExpand (Pbuiltin ef args res))) ->
- gen_bblocks thd tbdy tex = tbb :: nil ->
- header tbb = thd
- /\ body tbb = tbdy ++ extract_basic tex
- /\ exit tbb = extract_ctl tex.
-Proof.
- intros until tbb. intros Hnonil Hnobuiltin GENB. unfold gen_bblocks in GENB.
- destruct (extract_ctl tex) eqn:ECTL.
- - destruct c.
- + destruct i; try (inv GENB; simpl; auto; fail).
- assert False. eapply Hnobuiltin. eauto. destruct H.
- + inv GENB. simpl. auto.
- - inversion Hnonil.
- + destruct tbdy as [|bi tbdy]; try (contradict H; simpl; auto; fail). inv GENB. auto.
- + contradict H; simpl; auto.
-Qed.
-
-Lemma transl_instr_basic_nonil:
- forall k f bi ep x,
- transl_instr_basic f bi ep k = OK x ->
- x <> nil.
-Proof.
- intros until x. intros TIB.
- destruct bi.
- - simpl in TIB. unfold loadind in TIB. exploreInst; try discriminate.
- - simpl in TIB. unfold storeind in TIB. exploreInst; try discriminate.
- - simpl in TIB. monadInv TIB. unfold loadind in EQ. exploreInst; try discriminate.
- - simpl in TIB. unfold transl_op in TIB. exploreInst; try discriminate.
- unfold transl_cond_op in EQ0. exploreInst; try discriminate.
- unfold transl_cond_float64. exploreInst; try discriminate.
- unfold transl_cond_notfloat64. exploreInst; try discriminate.
- unfold transl_cond_float32. exploreInst; try discriminate.
- unfold transl_cond_notfloat32. exploreInst; try discriminate.
- - simpl in TIB. unfold transl_load in TIB. exploreInst; try discriminate.
- all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate.
- - simpl in TIB. unfold transl_store in TIB. exploreInst; try discriminate.
- all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate.
-Qed.
-
-Lemma transl_basic_code_nonil:
- forall bdy f x ep,
- bdy <> nil ->
- transl_basic_code f bdy ep = OK x ->
- x <> nil.
-Proof.
- induction bdy as [|bi bdy].
- intros. contradict H0; auto.
- destruct bdy as [|bi2 bdy].
- - clear IHbdy. intros f x b _ TBC. simpl in TBC. eapply transl_instr_basic_nonil; eauto.
- - intros f x b Hnonil TBC. remember (bi2 :: bdy) as bdy'.
- monadInv TBC.
- assert (x0 <> nil).
- eapply IHbdy; eauto. subst bdy'. discriminate.
- eapply transl_instr_basic_nonil; eauto.
-Qed.
-
-Lemma transl_instr_control_nonil:
- forall ex f x,
- ex <> None ->
- transl_instr_control f ex = OK x ->
- extract_ctl x <> None.
-Proof.
- intros ex f x Hnonil TIC.
- destruct ex as [ex|].
- - clear Hnonil. destruct ex.
- all: try (simpl in TIC; exploreInst; discriminate).
- + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; try discriminate.
- * unfold transl_opt_compuimm. exploreInst; try discriminate.
- * unfold transl_opt_compluimm. exploreInst; try discriminate.
- * unfold transl_comp_float64. exploreInst; try discriminate.
- * unfold transl_comp_notfloat64. exploreInst; try discriminate.
- * unfold transl_comp_float32. exploreInst; try discriminate.
- * unfold transl_comp_notfloat32. exploreInst; try discriminate.
- - contradict Hnonil; auto.
-Qed.
-
-Lemma transl_instr_control_nobuiltin:
- forall f ex x,
- (forall ef args res, ex <> Some (MBbuiltin ef args res)) ->
- transl_instr_control f ex = OK x ->
- (forall ef args res, extract_ctl x <> Some (PExpand (Pbuiltin ef args res))).
-Proof.
- intros until x. intros Hnobuiltin TIC. intros until res.
- unfold transl_instr_control in TIC. exploreInst.
- all: try discriminate.
- - assert False. eapply Hnobuiltin; eauto. destruct H.
- - unfold transl_cbranch in TIC. exploreInst.
- all: try discriminate.
- * unfold transl_opt_compuimm. exploreInst. all: try discriminate.
- * unfold transl_opt_compluimm. exploreInst. all: try discriminate.
- * unfold transl_comp_float64. exploreInst; try discriminate.
- * unfold transl_comp_notfloat64. exploreInst; try discriminate.
- * unfold transl_comp_float32. exploreInst; try discriminate.
- * unfold transl_comp_notfloat32. exploreInst; try discriminate.
-Qed.
-
-Theorem match_state_codestate:
- forall mbs abs s fb sp bb c ms m,
- (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) ->
- (MB.body bb <> nil \/ MB.exit bb <> None) ->
- mbs = (Machblock.State s fb sp (bb::c) ms m) ->
- match_states mbs abs ->
- exists cs fb f tbb tc ep,
- match_codestate fb mbs cs /\ match_asmstate fb cs abs
- /\ Genv.find_funct_ptr ge fb = Some (Internal f)
- /\ transl_blocks f (bb::c) ep = OK (tbb::tc)
- /\ body tbb = pbody1 cs ++ pbody2 cs
- /\ exit tbb = pctl cs
- /\ cur cs = Some tbb /\ rem cs = tc
- /\ pstate cs = abs.
-Proof.
- intros until m. intros Hnobuiltin Hnotempty Hmbs MS. subst. inv MS.
- inv AT. clear H0. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst.
- exploit transl_blocks_distrib; eauto. intros (TLB & TLBS). clear H2.
- monadInv TLB. exploit gen_bblocks_nobuiltin; eauto.
- { inversion Hnotempty.
- - destruct (MB.body bb) as [|bi bdy]; try (contradict H0; simpl; auto; fail).
- left. eapply transl_basic_code_nonil; eauto.
- - destruct (MB.exit bb) as [ei|]; try (contradict H0; simpl; auto; fail).
- right. eapply transl_instr_control_nonil; eauto. }
- eapply transl_instr_control_nobuiltin; eauto.
- intros (Hth & Htbdy & Htexit).
- exists {| pstate := (State rs m'); pheader := (Machblock.header bb); pbody1 := x; pbody2 := extract_basic x0;
- pctl := extract_ctl x0; fpok := ep; rem := tc'; cur := Some tbb |}, fb, f, tbb, tc', ep.
- repeat split. 1-2: econstructor; eauto.
- { destruct (MB.header bb). eauto. discriminate. } eauto.
- unfold transl_blocks. fold transl_blocks. unfold transl_block. rewrite EQ. simpl. rewrite EQ1; simpl.
- rewrite TLBS. simpl. rewrite H2.
- all: simpl; auto.
-Qed.
-
-Definition mb_remove_body (bb: MB.bblock) :=
- {| MB.header := MB.header bb; MB.body := nil; MB.exit := MB.exit bb |}.
-
-Lemma exec_straight_pnil:
- forall c rs1 m1 rs2 m2,
- exec_straight tge c rs1 m1 (Pnop::gnil) rs2 m2 ->
- exec_straight tge c rs1 m1 nil rs2 m2.
-Proof.
- intros. eapply exec_straight_trans. eapply H. econstructor; eauto.
-Qed.
-
-Lemma transl_block_nobuiltin:
- forall f bb ep tbb,
- (MB.body bb <> nil \/ MB.exit bb <> None) ->
- (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) ->
- transl_block f bb ep = OK (tbb :: nil) ->
- exists c c',
- transl_basic_code f (MB.body bb) ep = OK c
- /\ transl_instr_control f (MB.exit bb) = OK c'
- /\ body tbb = c ++ extract_basic c'
- /\ exit tbb = extract_ctl c'.
-Proof.
- intros until tbb. intros Hnonil Hnobuiltin TLB. monadInv TLB. destruct Hnonil.
- - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto.
- left. eapply transl_basic_code_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto.
- - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto.
- right. eapply transl_instr_control_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto.
-Qed.
-
-Lemma nextblock_preserves:
- forall rs rs' bb r,
- rs' = nextblock bb rs ->
- data_preg r = true ->
- rs r = rs' r.
-Proof.
- intros. destruct r; try discriminate.
- subst. Simpl.
-(* - subst. Simpl. *)
-Qed.
-
-Lemma cons3_app {A: Type}:
- forall a b c (l: list A),
- a :: b :: c :: l = (a :: b :: c :: nil) ++ l.
-Proof.
- intros. simpl. auto.
-Qed.
-
-Lemma exec_straight_opt_body2:
- forall c rs1 m1 c' rs2 m2,
- exec_straight_opt tge c rs1 m1 c' rs2 m2 ->
- exists body,
- exec_body tge body rs1 m1 = Next rs2 m2
- /\ (basics_to_code body) ++g c' = c.
-Proof.
- intros until m2. intros EXES.
- inv EXES.
- - exists nil. split; auto.
- - eapply exec_straight_body2. auto.
-Qed.
-
-Lemma extract_basics_to_code:
- forall lb c,
- extract_basic (basics_to_code lb ++ c) = lb ++ extract_basic c.
-Proof.
- induction lb; intros; simpl; congruence.
-Qed.
-
-Lemma extract_ctl_basics_to_code:
- forall lb c,
- extract_ctl (basics_to_code lb ++ c) = extract_ctl c.
-Proof.
- induction lb; intros; simpl; congruence.
-Qed.
-
-(* Lemma goto_label_inv:
- forall fn tbb l rs m b ofs,
- rs PC = Vptr b ofs ->
- goto_label fn l rs m = goto_label fn l (nextblock tbb rs) m.
-Proof.
- intros.
- unfold goto_label. rewrite nextblock_pc. unfold Val.offset_ptr. rewrite H.
- exploreInst; auto.
- unfold nextblock. rewrite Pregmap.gss.
-
-Qed.
-
-
-Lemma exec_control_goto_label_inv:
- exec_control tge fn (Some ctl) rs m = goto_label fn l rs m ->
- exec_control tge fn (Some ctl) (nextblock tbb rs) m = goto_label fn l (nextblock tbb rs) m.
-Proof.
-Qed. *)
-
-Theorem step_simu_control:
- forall bb' fb fn s sp c ms' m' rs2 m2 E0 S'' rs1 m1 tbb tbdy2 tex cs2,
- MB.body bb' = nil ->
- (forall ef args res, MB.exit bb' <> Some (MBbuiltin ef args res)) ->
- Genv.find_funct_ptr tge fb = Some (Internal fn) ->
- pstate cs2 = (Asmvliw.State rs2 m2) ->
- pbody1 cs2 = nil -> pbody2 cs2 = tbdy2 -> pctl cs2 = tex ->
- cur cs2 = Some tbb ->
- match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 ->
- match_asmstate fb cs2 (Asmvliw.State rs1 m1) ->
- exit_step return_address_offset ge (MB.exit bb') (MB.State s fb sp (bb'::c) ms' m') E0 S'' ->
- (exists rs3 m3 rs4 m4,
- exec_body tge tbdy2 rs2 m2 = Next rs3 m3
- /\ exec_control_rel tge fn tex tbb rs3 m3 rs4 m4
- /\ match_states S'' (State rs4 m4)).
-Proof.
- intros until cs2. intros Hbody Hbuiltin FIND Hpstate Hpbody1 Hpbody2 Hpctl Hcur MCS MAS ESTEP.
- inv ESTEP.
- - inv MCS. inv MAS. simpl in *.
- inv Hcur. inv Hpstate.
- destruct ctl.
- + (* MBcall *)
- destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.
- inv TBC. inv TIC. inv H0.
-
- assert (f0 = f) by congruence. subst f0.
- assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned).
- eapply transf_function_no_overflow; eauto.
- destruct s1 as [rf|fid]; simpl in H7.
- * (* Indirect call *)
- monadInv H1.
- assert (ms' rf = Vptr f' Ptrofs.zero).
- { unfold find_function_ptr in H14. destruct (ms' rf); try discriminate.
- revert H14; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. }
- assert (rs2 x = Vptr f' Ptrofs.zero).
- { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. }
- generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1.
- remember (Ptrofs.add _ _) as ofs'.
- assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc).
- { econstructor; eauto. }
- assert (f1 = f) by congruence. subst f1.
- exploit return_address_offset_correct; eauto. intros; subst ra.
-
- repeat eexists.
- rewrite H6. econstructor; eauto.
- rewrite H7. econstructor; eauto.
- econstructor; eauto.
- econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl.
- simpl. Simpl. rewrite PCeq. rewrite Heqofs'. simpl. auto.
-
- * (* Direct call *)
- monadInv H1.
- generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1.
- remember (Ptrofs.add _ _) as ofs'.
- assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc).
- econstructor; eauto.
- assert (f1 = f) by congruence. subst f1.
- exploit return_address_offset_correct; eauto. intros; subst ra.
- repeat eexists.
- rewrite H6. econstructor; eauto.
- rewrite H7. econstructor; eauto.
- econstructor; eauto.
- econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl.
- Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. simpl in H14. rewrite H14. auto.
- Simpl. simpl. subst. Simpl. simpl. unfold Val.offset_ptr. rewrite PCeq. auto.
- + (* MBtailcall *)
- destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.
- inv TBC. inv TIC. inv H0.
-
- assert (f0 = f) by congruence. subst f0.
- assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned).
- eapply transf_function_no_overflow; eauto.
- exploit Mem.loadv_extends. eauto. eexact H15. auto. simpl. intros [parent' [A B]].
- destruct s1 as [rf|fid]; simpl in H13.
- * monadInv H1.
- assert (ms' rf = Vptr f' Ptrofs.zero).
- { destruct (ms' rf); try discriminate. revert H13. predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. }
- assert (rs2 x = Vptr f' Ptrofs.zero).
- { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. }
-
- assert (f = f1) by congruence. subst f1. clear FIND1. clear H14.
- exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z).
- exploit exec_straight_body; eauto.
- { simpl. eauto. }
- intros EXEB.
- repeat eexists.
- rewrite H6. simpl extract_basic. eauto.
- rewrite H7. simpl extract_ctl. simpl. reflexivity.
- econstructor; eauto.
- { apply agree_set_other.
- - econstructor; auto with asmgen.
- + apply V.
- + intro r. destruct r; apply V; auto.
- - eauto with asmgen. }
- assert (IR x <> IR GPR12 /\ IR x <> IR GPR32 /\ IR x <> IR GPR16).
- { clear - EQ. destruct x; repeat split; try discriminate.
- all: unfold ireg_of in EQ; destruct rf; try discriminate. }
- Simpl. inv H1. inv H3. rewrite Z; auto; try discriminate.
- * monadInv H1. assert (f = f1) by congruence. subst f1. clear FIND1. clear H14.
- exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z).
- exploit exec_straight_body; eauto.
- simpl. eauto.
- intros EXEB.
- repeat eexists.
- rewrite H6. simpl extract_basic. eauto.
- rewrite H7. simpl extract_ctl. simpl. reflexivity.
- econstructor; eauto.
- { apply agree_set_other.
- - econstructor; auto with asmgen.
- + apply V.
- + intro r. destruct r; apply V; auto.
- - eauto with asmgen. }
- { Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H13. auto. }
- + (* MBbuiltin (contradiction) *)
- assert (MB.exit bb' <> Some (MBbuiltin e l b)) by (apply Hbuiltin).
- rewrite <- H in H1. contradict H1; auto.
- + (* MBgoto *)
- destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.
- inv TBC. inv TIC. inv H0.
-
- assert (f0 = f) by congruence. subst f0. assert (f1 = f) by congruence. subst f1. clear H11.
- remember (nextblock tbb rs2) as rs2'.
- (* inv AT. monadInv H4. *)
- exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND'.
- assert (tf = fn) by congruence. subst tf.
- exploit find_label_goto_label.
- eauto. eauto.
- instantiate (2 := rs2').
- { subst. unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. eauto. }
- eauto.
- intros (tc' & rs' & GOTO & AT2 & INV).
-
- eexists. eexists. repeat eexists. repeat split.
- rewrite H6. simpl extract_basic. simpl. eauto.
- rewrite H7. simpl extract_ctl. simpl. rewrite <- Heqrs2'. eauto.
- econstructor; eauto.
- rewrite Heqrs2' in INV. unfold nextblock, incrPC in INV.
- eapply agree_exten; eauto with asmgen.
- assert (forall r : preg, r <> PC -> rs' r = rs2 r).
- { intros. destruct r.
- - destruct g. all: rewrite INV; Simpl; auto.
-(* - destruct g. all: rewrite INV; Simpl; auto. *)
- - rewrite INV; Simpl; auto.
- - contradiction. }
- eauto with asmgen.
- congruence.
- + (* MBcond *)
- destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.
- inv TBC. inv TIC. inv H0.
-
- * (* MBcond true *)
- assert (f0 = f) by congruence. subst f0.
- exploit eval_condition_lessdef.
- eapply preg_vals; eauto.
- all: eauto.
- intros EC.
- exploit transl_cbranch_correct_true; eauto. intros (rs' & jmp & A & B & C).
- exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC).
- assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. }
- rewrite PCeq' in PCeq.
- assert (f1 = f) by congruence. subst f1.
- exploit find_label_goto_label.
- 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs')). rewrite nextblock_pc.
- unfold Val.offset_ptr. rewrite PCeq. eauto.
- intros (tc' & rs3 & GOTOL & TLPC & Hrs3).
- exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'.
- assert (tf = fn) by congruence. subst tf.
-
- repeat eexists.
- rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto.
- rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto.
-
- econstructor; eauto.
- eapply agree_exten with rs2; eauto with asmgen.
- { intros. destruct r; try destruct g; try discriminate.
- all: rewrite Hrs3; try discriminate; unfold nextblock, incrPC; Simpl. }
- intros. discriminate.
-
- * (* MBcond false *)
- assert (f0 = f) by congruence. subst f0.
- exploit eval_condition_lessdef.
- eapply preg_vals; eauto.
- all: eauto.
- intros EC.
-
- exploit transl_cbranch_correct_false; eauto. intros (rs' & jmp & A & B & C).
- exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC).
- assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. }
- rewrite PCeq' in PCeq.
- exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'.
- assert (tf = fn) by congruence. subst tf.
-
- assert (NOOV: size_blocks fn.(fn_blocks) <= Ptrofs.max_unsigned).
- eapply transf_function_no_overflow; eauto.
- generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1.
-
- repeat eexists.
- rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto.
- rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto.
-
- econstructor; eauto.
- unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. econstructor; eauto.
- eapply agree_exten with rs2; eauto with asmgen.
- { intros. destruct r; try destruct g; try discriminate.
- all: rewrite <- C; try discriminate; unfold nextblock, incrPC; Simpl. }
- intros. discriminate.
- + (* MBjumptable *)
- destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.
- inv TBC. inv TIC. inv H0.
-
- assert (f0 = f) by congruence. subst f0.
- monadInv H1.
- generalize (transf_function_no_overflow _ _ TRANSF0); intro NOOV.
- assert (f1 = f) by congruence. subst f1.
- exploit find_label_goto_label. 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs2) # GPR62 <- Vundef # GPR63 <- Vundef).
- unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. reflexivity.
- exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND3. assert (fn = tf) by congruence. subst fn.
-
- intros [tc' [rs' [A [B C]]]].
- exploit ireg_val; eauto. rewrite H13. intros LD; inv LD.
-
- repeat eexists.
- rewrite H6. simpl extract_basic. simpl. eauto.
- rewrite H7. simpl extract_ctl. simpl. Simpl. rewrite <- H1. unfold Mach.label in H14. unfold label. rewrite H14. eapply A.
- econstructor; eauto.
- eapply agree_undef_regs; eauto. intros. rewrite C; auto with asmgen.
- { assert (destroyed_by_jumptable = R62 :: R63 :: nil) by auto. rewrite H2 in H0. simpl in H0. inv H0.
- destruct (preg_eq r' GPR63). subst. contradiction.
- destruct (preg_eq r' GPR62). subst. contradiction.
- destruct r'; Simpl. }
- discriminate.
- + (* MBreturn *)
- destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.
- inv TBC. inv TIC. inv H0.
-
- assert (f0 = f) by congruence. subst f0.
- assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned).
- eapply transf_function_no_overflow; eauto.
- exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z).
- exploit exec_straight_body; eauto.
- simpl. eauto.
- intros EXEB.
- assert (f1 = f) by congruence. subst f1.
-
- repeat eexists.
- rewrite H6. simpl extract_basic. eauto.
- rewrite H7. simpl extract_ctl. simpl. reflexivity.
- econstructor; eauto.
- unfold nextblock, incrPC. repeat apply agree_set_other; auto with asmgen.
-
- - inv MCS. inv MAS. simpl in *. subst. inv Hpstate. inv Hcur.
-(* exploit transl_blocks_distrib; eauto. (* rewrite <- H2. discriminate. *)
- intros (TLB & TLBS).
- *) destruct bb' as [hd' bdy' ex']; simpl in *. subst.
-(* unfold transl_block in TLB. simpl in TLB. unfold gen_bblocks in TLB; simpl in TLB. inv TLB. *)
- monadInv TBC. monadInv TIC. simpl in *. rewrite H5. rewrite H6.
- simpl. repeat eexists.
- econstructor. 4: instantiate (3 := false). all:eauto.
- unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq.
- assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned).
- eapply transf_function_no_overflow; eauto.
- assert (f = f0) by congruence. subst f0. econstructor; eauto.
- generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. eauto.
- eapply agree_exten; eauto. intros. Simpl.
- discriminate.
-Qed.
-
-Definition mb_remove_first (bb: MB.bblock) :=
- {| MB.header := MB.header bb; MB.body := tail (MB.body bb); MB.exit := MB.exit bb |}.
-
-Lemma exec_straight_body:
- forall c c' lc rs1 m1 rs2 m2,
- exec_straight tge c rs1 m1 c' rs2 m2 ->
- code_to_basics c = Some lc ->
- exists l ll,
- c = l ++ c'
- /\ code_to_basics l = Some ll
- /\ exec_body tge ll rs1 m1 = Next rs2 m2.
-Proof.
- induction c; try (intros; inv H; fail).
- intros until m2. intros EXES CTB. inv EXES.
- - exists (i1 ::g nil),(i1::nil). repeat (split; simpl; auto). rewrite H6. auto.
- - inv CTB. destruct (code_to_basics c); try discriminate. inv H0.
- eapply IHc in H7; eauto. destruct H7 as (l' & ll & Hc & CTB & EXECB). subst.
- exists (i ::g l'),(i::ll). repeat (split; simpl; auto).
- rewrite CTB. auto.
- rewrite H1. auto.
-Qed.
-
-Lemma basics_to_code_app:
- forall c l x ll,
- basics_to_code c = l ++ basics_to_code x ->
- code_to_basics l = Some ll ->
- c = ll ++ x.
-Proof.
- intros. apply (f_equal code_to_basics) in H.
- erewrite code_to_basics_dist in H; eauto. 2: eapply code_to_basics_id.
- rewrite code_to_basics_id in H. inv H. auto.
-Qed.
-
-Lemma basics_to_code_app2:
- forall i c l x ll,
- (PBasic i) :: basics_to_code c = l ++ basics_to_code x ->
- code_to_basics l = Some ll ->
- i :: c = ll ++ x.
-Proof.
- intros until ll. intros.
- exploit basics_to_code_app. instantiate (3 := (i::c)). simpl.
- all: eauto.
-Qed.
-
-Lemma step_simu_basic:
- forall bb bb' s fb sp c ms m rs1 m1 ms' m' bi cs1 tbdy bdy,
- MB.header bb = nil -> MB.body bb = bi::(bdy) -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) ->
- bb' = {| MB.header := nil; MB.body := bdy; MB.exit := MB.exit bb |} ->
- basic_step ge s fb sp ms m bi ms' m' ->
- pstate cs1 = (State rs1 m1) -> pbody1 cs1 = tbdy ->
- match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 ->
- (exists rs2 m2 l cs2 tbdy',
- cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := tbdy'; pbody2 := pbody2 cs1;
- pctl := pctl cs1; fpok := fp_is_parent (fpok cs1) bi; rem := rem cs1; cur := cur cs1 |}
- /\ tbdy = l ++ tbdy'
- /\ exec_body tge l rs1 m1 = Next rs2 m2
- /\ match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2).
-Proof.
- intros until bdy. intros Hheader Hbody Hnobuiltin (* Hnotempty *) Hbb' BSTEP Hpstate Hpbody1 MCS. inv MCS.
- simpl in *. inv Hpstate.
- rewrite Hbody in TBC. monadInv TBC.
- inv BSTEP.
- - (* MBgetstack *)
- simpl in EQ0.
- unfold Mach.load_stack in H.
- exploit Mem.loadv_extends; eauto. intros [v' [A B]].
- rewrite (sp_val _ _ _ AG) in A.
- exploit loadind_correct; eauto with asmgen.
- intros (rs2 & EXECS & Hrs'1 & Hrs'2).
- eapply exec_straight_body in EXECS.
- 2: eapply code_to_basics_id; eauto.
- destruct EXECS as (l & Hlbi & BTC & CTB & EXECB).
- exists rs2, m1, Hlbi.
- eexists. eexists. split. instantiate (1 := x). eauto.
- repeat (split; auto).
- eapply basics_to_code_app; eauto.
- remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
-(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. }
- rewrite <- Hheadereq. *) subst.
-
- eapply match_codestate_intro; eauto. simpl. simpl in EQ. (* { destruct (MB.header bb); auto. } *)
- eapply agree_set_mreg; eauto with asmgen.
- intro Hep. simpl in Hep. inv Hep.
- - (* MBsetstack *)
- simpl in EQ0.
- unfold Mach.store_stack in H.
- assert (Val.lessdef (ms src) (rs1 (preg_of src))). { eapply preg_val; eauto. }
- exploit Mem.storev_extends; eauto. intros [m2' [A B]].
- exploit storeind_correct; eauto with asmgen.
- rewrite (sp_val _ _ _ AG) in A. eauto. intros [rs' [P Q]].
-
- eapply exec_straight_body in P.
- 2: eapply code_to_basics_id; eauto.
- destruct P as (l & ll & TBC & CTB & EXECB).
- exists rs', m2', ll.
- eexists. eexists. split. instantiate (1 := x). eauto.
- repeat (split; auto).
- eapply basics_to_code_app; eauto.
- remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
-(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. }
- rewrite <- Hheadereq. *) subst.
- eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto.
-
- eapply agree_undef_regs; eauto with asmgen.
- simpl; intros. rewrite Q; auto with asmgen. rewrite Hheader in DXP. auto.
- - (* MBgetparam *)
- simpl in EQ0.
-
- assert (f0 = f) by congruence; subst f0.
- unfold Mach.load_stack in *.
- exploit Mem.loadv_extends. eauto. eexact H0. auto.
- intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A.
- exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'.
- exploit Mem.loadv_extends. eauto. eexact H1. auto.
- intros [v' [C D]].
-
- (* Opaque loadind. *)
-(* left; eapply exec_straight_steps; eauto; intros. monadInv TR. *)
- monadInv EQ0. rewrite Hheader. rewrite Hheader in DXP.
- destruct ep eqn:EPeq.
- (* RTMP contains parent *)
- + exploit loadind_correct. eexact EQ1.
- instantiate (2 := rs1). rewrite DXP; eauto.
- intros [rs2 [P [Q R]]].
-
- eapply exec_straight_body in P.
- 2: eapply code_to_basics_id; eauto.
- destruct P as (l & ll & BTC & CTB & EXECB).
- exists rs2, m1, ll. eexists.
- eexists. split. instantiate (1 := x). eauto.
- repeat (split; auto).
- { eapply basics_to_code_app; eauto. }
- remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
- assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. }
- (* rewrite <- Hheadereq. *)subst.
- eapply match_codestate_intro; eauto.
-
- eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen.
- simpl; intros. rewrite R; auto with asmgen.
- apply preg_of_not_FP; auto.
-
- (* GPR11 does not contain parent *)
- + rewrite chunk_of_Tptr in A.
- exploit loadind_ptr_correct. eexact A. intros [rs2 [P [Q R]]].
- exploit loadind_correct. eexact EQ1. instantiate (2 := rs2). rewrite Q. eauto.
- intros [rs3 [S [T U]]].
-
- exploit exec_straight_trans.
- eapply P.
- eapply S.
- intros EXES.
-
- eapply exec_straight_body in EXES.
- 2: simpl. 2: erewrite code_to_basics_id; eauto.
- destruct EXES as (l & ll & BTC & CTB & EXECB).
- exists rs3, m1, ll.
- eexists. eexists. split. instantiate (1 := x). eauto.
- repeat (split; auto).
- eapply basics_to_code_app2; eauto.
- remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
- assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. }
- subst.
- eapply match_codestate_intro; eauto.
- eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto.
- instantiate (1 := rs2#FP <- (rs3#FP)). intros.
- rewrite Pregmap.gso; auto with asmgen.
- congruence.
- intros. unfold Pregmap.set. destruct (PregEq.eq r' FP). congruence. auto with asmgen.
- simpl; intros. rewrite U; auto with asmgen.
- apply preg_of_not_FP; auto.
- - (* MBop *)
- simpl in EQ0. rewrite Hheader in DXP.
-
- assert (eval_operation tge sp op (map ms args) m' = Some v).
- rewrite <- H. apply eval_operation_preserved. exact symbols_preserved.
- exploit eval_operation_lessdef.
- eapply preg_vals; eauto.
- 2: eexact H0.
- all: eauto.
- intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A.
- exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]].
-
- eapply exec_straight_body in P.
- 2: eapply code_to_basics_id; eauto.
- destruct P as (l & ll & TBC & CTB & EXECB).
- exists rs2, m1, ll.
- eexists. eexists. split. instantiate (1 := x). eauto.
- repeat (split; auto).
- eapply basics_to_code_app; eauto.
- remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
-(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. }
- rewrite <- Hheadereq. *) subst.
- eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto.
- apply agree_set_undef_mreg with rs1; auto.
- apply Val.lessdef_trans with v'; auto.
- simpl; intros. destruct (andb_prop _ _ H1); clear H1.
- rewrite R; auto. apply preg_of_not_FP; auto.
-Local Transparent destroyed_by_op.
- destruct op; simpl; auto; congruence.
- - (* MBload *)
- simpl in EQ0. rewrite Hheader in DXP.
-
- assert (eval_addressing tge sp addr (map ms args) = Some a).
- rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
- exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1.
- intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A.
- exploit Mem.loadv_extends; eauto. intros [v' [C D]].
- exploit transl_load_correct; eauto.
- intros [rs2 [P [Q R]]].
-
- eapply exec_straight_body in P.
- 2: eapply code_to_basics_id; eauto.
- destruct P as (l & ll & TBC & CTB & EXECB).
- exists rs2, m1, ll.
- eexists. eexists. split. instantiate (1 := x). eauto.
- repeat (split; auto).
- eapply basics_to_code_app; eauto.
- remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
-(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. }
- rewrite <- Hheadereq. *) subst.
- eapply match_codestate_intro; eauto. simpl. simpl in EQ.
-
- eapply agree_set_undef_mreg; eauto. intros; auto with asmgen.
- simpl; congruence.
-
- - (* MBstore *)
- simpl in EQ0. rewrite Hheader in DXP.
-
- assert (eval_addressing tge sp addr (map ms args) = Some a).
- rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
- exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1.
- intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A.
- assert (Val.lessdef (ms src) (rs1 (preg_of src))). eapply preg_val; eauto.
- exploit Mem.storev_extends; eauto. intros [m2' [C D]].
- exploit transl_store_correct; eauto. intros [rs2 [P Q]].
-
- eapply exec_straight_body in P.
- 2: eapply code_to_basics_id; eauto.
- destruct P as (l & ll & TBC & CTB & EXECB).
- exists rs2, m2', ll.
- eexists. eexists. split. instantiate (1 := x). eauto.
- repeat (split; auto).
- eapply basics_to_code_app; eauto.
- remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
- subst.
- eapply match_codestate_intro; eauto. simpl. simpl in EQ.
-
- eapply agree_undef_regs; eauto with asmgen.
- simpl; congruence.
-Qed.
-
-Lemma exec_body_trans:
- forall l l' rs0 m0 rs1 m1 rs2 m2,
- exec_body tge l rs0 m0 = Next rs1 m1 ->
- exec_body tge l' rs1 m1 = Next rs2 m2 ->
- exec_body tge (l++l') rs0 m0 = Next rs2 m2.
-Proof.
- induction l.
- - simpl. congruence.
- - intros until m2. intros EXEB1 EXEB2.
- inv EXEB1. destruct (exec_basic_instr _) eqn:EBI; try discriminate.
- simpl. rewrite EBI. eapply IHl; eauto.
-Qed.
-
-Definition mb_remove_header bb := {| MB.header := nil; MB.body := MB.body bb; MB.exit := MB.exit bb |}.
-
-Program Definition remove_header tbb := {| header := nil; body := body tbb; exit := exit tbb |}.
-Next Obligation.
- destruct tbb. simpl. auto.
-Qed.
-
-Inductive exec_header: codestate -> codestate -> Prop :=
- | exec_header_cons: forall cs1,
- exec_header cs1 {| pstate := pstate cs1; pheader := nil; pbody1 := pbody1 cs1; pbody2 := pbody2 cs1;
- pctl := pctl cs1; fpok := (if pheader cs1 then fpok cs1 else false); rem := rem cs1;
- (* cur := match cur cs1 with None => None | Some bcur => Some (remove_header bcur) end *)
- cur := cur cs1 |}.
-
-Lemma step_simu_header:
- forall bb s fb sp c ms m rs1 m1 cs1,
-(* (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> *)
- pstate cs1 = (State rs1 m1) ->
- match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 ->
- (exists cs1',
- exec_header cs1 cs1'
- /\ match_codestate fb (MB.State s fb sp (mb_remove_header bb::c) ms m) cs1').
-Proof.
- intros until cs1. intros Hpstate MCS.
- eexists. split; eauto.
- econstructor; eauto.
- inv MCS. simpl in *. inv Hpstate.
- econstructor; eauto.
-Qed.
-
-Lemma step_matchasm_header:
- forall fb cs1 cs1' s1,
- match_asmstate fb cs1 s1 ->
- exec_header cs1 cs1' ->
- match_asmstate fb cs1' s1.
-Proof.
- intros until s1. intros MAS EXH.
- inv MAS. inv EXH.
- simpl. econstructor; eauto.
-Qed.
-
-Lemma step_simu_body:
- forall bb s fb sp c ms m rs1 m1 ms' cs1 m',
- MB.header bb = nil ->
- (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) ->
- body_step ge s fb sp (MB.body bb) ms m ms' m' ->
- pstate cs1 = (State rs1 m1) ->
- match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 ->
- (exists rs2 m2 cs2 ep,
- cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := nil; pbody2 := pbody2 cs1;
- pctl := pctl cs1; fpok := ep; rem := rem cs1; cur := cur cs1 |}
- /\ exec_body tge (pbody1 cs1) rs1 m1 = Next rs2 m2
- /\ match_codestate fb (MB.State s fb sp ({| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |}::c) ms' m') cs2).
-Proof.
- intros bb. destruct bb as [hd bdy ex]; simpl; auto. induction bdy as [|bi bdy].
- - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS.
- inv BSTEP.
- exists rs1, m1, cs1, (fpok cs1).
- inv MCS. inv Hpstate. simpl in *. monadInv TBC. repeat (split; simpl; auto).
- econstructor; eauto.
- - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. inv BSTEP.
- rename ms' into ms''. rename m' into m''. rename rs' into ms'. rename m'0 into m'.
- exploit (step_simu_basic); eauto. simpl. eauto. simpl; auto. simpl; auto.
- intros (rs2 & m2 & l & cs2 & tbdy' & Hcs2 & Happ & EXEB & MCS').
- simpl in *.
- exploit IHbdy. auto. 2: eapply H6. 3: eapply MCS'. all: eauto. subst; eauto. simpl; auto.
- intros (rs3 & m3 & cs3 & ep & Hcs3 & EXEB' & MCS'').
- exists rs3, m3, cs3, ep.
- repeat (split; simpl; auto). subst. simpl in *. auto.
- rewrite Happ. eapply exec_body_trans; eauto. rewrite Hcs2 in EXEB'; simpl in EXEB'. auto.
-Qed.
-
-(* Lemma exec_body_straight:
- forall l rs0 m0 rs1 m1,
- l <> nil ->
- exec_body tge l rs0 m0 = Next rs1 m1 ->
- exec_straight tge l rs0 m0 nil rs1 m1.
-Proof.
- induction l as [|i1 l].
- intros. contradict H; auto.
- destruct l as [|i2 l].
- - intros until m1. intros _ EXEB. simpl in EXEB.
- destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate.
- inv EXEB. econstructor; eauto.
- - intros until m1. intros _ EXEB. simpl in EXEB. simpl in IHl.
- destruct (exec_basic_instr tge i1 rs0 m0) eqn:EBI; try discriminate.
- econstructor; eauto. eapply IHl; eauto. discriminate.
-Qed. *)
-
-Lemma exec_body_pc:
- forall l rs1 m1 rs2 m2,
- exec_body tge l rs1 m1 = Next rs2 m2 ->
- rs2 PC = rs1 PC.
-Proof.
- induction l.
- - intros. inv H. auto.
- - intros until m2. intro EXEB.
- inv EXEB. destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate.
- eapply IHl in H0. rewrite H0.
- erewrite exec_basic_instr_pc; eauto.
-Qed.
-
-Lemma exec_body_control:
- forall b rs1 m1 rs2 m2 rs3 m3 fn,
- exec_body tge (body b) rs1 m1 = Next rs2 m2 ->
- exec_control_rel tge fn (exit b) b rs2 m2 rs3 m3 ->
- exec_bblock_rel tge fn b rs1 m1 rs3 m3.
-Proof.
- intros until fn. intros EXEB EXECTL.
- econstructor; eauto. inv EXECTL.
- unfold exec_bblock. rewrite EXEB. auto.
-Qed.
-
-Definition mbsize (bb: MB.bblock) := (length (MB.body bb) + length_opt (MB.exit bb))%nat.
-
-Lemma mbsize_eqz:
- forall bb, mbsize bb = 0%nat -> MB.body bb = nil /\ MB.exit bb = None.
-Proof.
- intros. destruct bb as [hd bdy ex]; simpl in *. unfold mbsize in H.
- remember (length _) as a. remember (length_opt _) as b.
- assert (a = 0%nat) by omega. assert (b = 0%nat) by omega. subst. clear H.
- inv H0. inv H1. destruct bdy; destruct ex; auto.
- all: try discriminate.
-Qed.
-
-Lemma mbsize_neqz:
- forall bb, mbsize bb <> 0%nat -> (MB.body bb <> nil \/ MB.exit bb <> None).
-Proof.
- intros. destruct bb as [hd bdy ex]; simpl in *.
- destruct bdy; destruct ex; try (right; discriminate); try (left; discriminate).
- contradict H. unfold mbsize. simpl. auto.
-Qed.
-
-(* Alternative form of step_simulation_bblock, easier to prove *)
-Lemma step_simulation_bblock':
- forall sf f sp bb bb' bb'' rs m rs' m' s'' c S1,
- bb' = mb_remove_header bb ->
- body_step ge sf f sp (Machblock.body bb') rs m rs' m' ->
- bb'' = mb_remove_body bb' ->
- (forall ef args res, MB.exit bb'' <> Some (MBbuiltin ef args res)) ->
- exit_step return_address_offset ge (Machblock.exit bb'') (Machblock.State sf f sp (bb'' :: c) rs' m') E0 s'' ->
- match_states (Machblock.State sf f sp (bb :: c) rs m) S1 ->
- exists S2 : state, plus step tge S1 E0 S2 /\ match_states s'' S2.
-Proof.
- intros until S1. intros Hbb' BSTEP Hbb'' Hbuiltin ESTEP MS.
- destruct (mbsize bb) eqn:SIZE.
- - apply mbsize_eqz in SIZE. destruct SIZE as (Hbody & Hexit).
- destruct bb as [hd bdy ex]; simpl in *; subst.
- inv MS. inv AT. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc.
- monadInv H2. simpl in *. inv ESTEP. inv BSTEP.
- eexists. split. eapply plus_one.
- exploit functions_translated; eauto. intros (tf0 & FIND' & TRANSF'). monadInv TRANSF'.
- assert (x = tf) by congruence. subst x.
- eapply exec_step_internal; eauto. eapply find_bblock_tail; eauto.
- unfold exec_bblock. simpl. eauto.
- econstructor. eauto. eauto. eauto.
- unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite <- H.
- assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned).
- eapply transf_function_no_overflow; eauto.
- econstructor; eauto.
- generalize (code_tail_next_int _ _ _ _ NOOV H3). intro CT1. eauto.
- eapply agree_exten; eauto. intros. Simpl.
- intros. discriminate.
- - subst. exploit mbsize_neqz. { instantiate (1 := bb). rewrite SIZE. discriminate. }
- intros Hnotempty.
-
- (* initial setting *)
- exploit match_state_codestate.
- 2: eapply Hnotempty.
- all: eauto.
- intros (cs1 & fb & f0 & tbb & tc & ep & MCS & MAS & FIND & TLBS & Hbody & Hexit & Hcur & Hrem & Hpstate).
-
- (* step_simu_header part *)
- assert (exists rs1 m1, pstate cs1 = State rs1 m1). { inv MAS. simpl. eauto. }
- destruct H as (rs1 & m1 & Hpstate2). subst.
- assert (f = fb). { inv MCS. auto. } subst fb.
- exploit step_simu_header.
- 2: eapply MCS.
- all: eauto.
- intros (cs1' & EXEH & MCS2).
-
- (* step_simu_body part *)
-(* assert (MB.body bb = MB.body (mb_remove_header bb)). { destruct bb; simpl; auto. }
- rewrite H in BSTEP. clear H. *)
- assert (Hpstate': pstate cs1' = pstate cs1). { inv EXEH; auto. }
- exploit step_simu_body.
- 3: eapply BSTEP.
- 4: eapply MCS2.
- all: eauto. rewrite Hpstate'. eauto.
- intros (rs2 & m2 & cs2 & ep' & Hcs2 & EXEB & MCS').
-
- (* step_simu_control part *)
- assert (exists tf, Genv.find_funct_ptr tge f = Some (Internal tf)).
- { exploit functions_translated; eauto. intros (tf & FIND' & TRANSF'). monadInv TRANSF'. eauto. }
- destruct H as (tf & FIND').
- assert (exists tex, pbody2 cs1 = extract_basic tex /\ pctl cs1 = extract_ctl tex).
- { inv MAS. simpl in *. eauto. }
- destruct H as (tex & Hpbody2 & Hpctl).
- inv EXEH. simpl in *.
- subst. exploit step_simu_control.
- 9: eapply MCS'. all: simpl.
- 10: eapply ESTEP.
- all: simpl; eauto.
- rewrite Hpbody2. rewrite Hpctl. rewrite Hcur.
- { inv MAS; simpl in *. inv Hcur. inv Hpstate2. eapply match_asmstate_some; eauto.
- erewrite exec_body_pc; eauto. }
- intros (rs3 & m3 & rs4 & m4 & EXEB' & EXECTL' & MS').
-
- (* bringing the pieces together *)
- exploit exec_body_trans.
- eapply EXEB.
- eauto.
- intros EXEB2.
- exploit exec_body_control; eauto.
- rewrite <- Hpbody2 in EXEB2. rewrite <- Hbody in EXEB2. eauto.
- rewrite Hexit. rewrite Hpctl. eauto.
- intros EXECB. inv EXECB.
- exists (State rs4 m4).
- split; auto. eapply plus_one. rewrite Hpstate2.
- assert (exists ofs, rs1 PC = Vptr f ofs).
- { rewrite Hpstate2 in MAS. inv MAS. simpl in *. eauto. }
- destruct H0 as (ofs & Hrs1pc).
- eapply exec_step_internal; eauto.
-
- (* proving the initial find_bblock *)
- rewrite Hpstate2 in MAS. inv MAS. simpl in *.
- assert (f1 = f0) by congruence. subst f0.
- rewrite PCeq in Hrs1pc. inv Hrs1pc.
- exploit functions_translated; eauto. intros (tf1 & FIND'' & TRANS''). rewrite FIND' in FIND''.
- inv FIND''. monadInv TRANS''. rewrite TRANSF0 in EQ. inv EQ. inv Hcur.
- eapply find_bblock_tail; eauto.
-Qed.
-
-Lemma step_simulation_bblock:
- forall sf f sp bb ms m ms' m' S2 c,
- body_step ge sf f sp (Machblock.body bb) ms m ms' m' ->
- (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) ->
- exit_step return_address_offset ge (Machblock.exit bb) (Machblock.State sf f sp (bb :: c) ms' m') E0 S2 ->
- forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' ->
- exists S2' : state, plus step tge S1' E0 S2' /\ match_states S2 S2'.
-Proof.
- intros until c. intros BSTEP Hbuiltin ESTEP S1' MS.
- eapply step_simulation_bblock'; eauto.
- all: destruct bb as [hd bdy ex]; simpl in *; eauto.
- inv ESTEP.
- - econstructor. inv H; try (econstructor; eauto; fail).
- - econstructor.
-Qed.
-
-Definition measure (s: MB.state) : nat :=
- match s with
- | MB.State _ _ _ _ _ _ => 0%nat
- | MB.Callstate _ _ _ _ => 0%nat
- | MB.Returnstate _ _ _ => 1%nat
- end.
-
-Definition split (c: MB.code) :=
- match c with
- | nil => nil
- | bb::c => {| MB.header := MB.header bb; MB.body := MB.body bb; MB.exit := None |}
- :: {| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |} :: c
- end.
-
-Lemma cons_ok_eq3 {A: Type} :
- forall (x:A) y z x' y' z',
- x = x' -> y = y' -> z = z' ->
- OK (x::y::z) = OK (x'::y'::z').
-Proof.
- intros. subst. auto.
-Qed.
-
-Lemma transl_blocks_split_builtin:
- forall bb c ep f ef args res,
- MB.exit bb = Some (MBbuiltin ef args res) -> MB.body bb <> nil ->
- transl_blocks f (split (bb::c)) ep = transl_blocks f (bb::c) ep.
-Proof.
- intros until res. intros Hexit Hbody. simpl split.
- unfold transl_blocks. fold transl_blocks. unfold transl_block.
- simpl. remember (transl_basic_code _ _ _) as tbc. remember (transl_instr_control _ _) as tbi.
- remember (transl_blocks _ _ _) as tlbs.
- destruct tbc; destruct tbi; destruct tlbs.
- all: try simpl; auto.
- - simpl. rewrite Hexit in Heqtbi. simpl in Heqtbi. monadInv Heqtbi. simpl.
- unfold gen_bblocks. simpl. destruct l.
- + exploit transl_basic_code_nonil; eauto. intro. destruct H.
- + simpl. rewrite app_nil_r. apply cons_ok_eq3. all: try eapply bblock_equality. all: simpl; auto.
-Qed.
-
-Lemma transl_code_at_pc_split_builtin:
- forall rs f f0 bb c ep tf tc ef args res,
- MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) ->
- transl_code_at_pc ge (rs PC) f f0 (bb :: c) ep tf tc ->
- transl_code_at_pc ge (rs PC) f f0 (split (bb :: c)) ep tf tc.
-Proof.
- intros until res. intros Hbody Hexit AT. inv AT.
- econstructor; eauto. erewrite transl_blocks_split_builtin; eauto.
-Qed.
-
-Theorem match_states_split_builtin:
- forall sf f sp bb c rs m ef args res S1,
- MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) ->
- match_states (Machblock.State sf f sp (bb :: c) rs m) S1 ->
- match_states (Machblock.State sf f sp (split (bb::c)) rs m) S1.
-Proof.
- intros until S1. intros Hbody Hexit MS.
- inv MS.
- econstructor; eauto.
- eapply transl_code_at_pc_split_builtin; eauto.
-Qed.
-
-Lemma step_simulation_builtin:
- forall ef args res bb sf f sp c ms m t S2,
- MB.body bb = nil -> MB.exit bb = Some (MBbuiltin ef args res) ->
- exit_step return_address_offset ge (MB.exit bb) (Machblock.State sf f sp (bb :: c) ms m) t S2 ->
- forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' ->
- exists S2' : state, plus step tge S1' t S2' /\ match_states S2 S2'.
-Proof.
- intros until S2. intros Hbody Hexit ESTEP S1' MS.
- inv MS. inv AT. monadInv H2. monadInv EQ.
- rewrite Hbody in EQ0. monadInv EQ0.
- rewrite Hexit in EQ. monadInv EQ.
- rewrite Hexit in ESTEP. inv ESTEP. inv H4.
-
- exploit functions_transl; eauto. intro FN.
- generalize (transf_function_no_overflow _ _ H1); intro NOOV.
- exploit builtin_args_match; eauto. intros [vargs' [P Q]].
- exploit external_call_mem_extends; eauto.
- intros [vres' [m2' [A [B [C D]]]]].
- econstructor; split. apply plus_one.
- simpl in H3.
- eapply exec_step_builtin. eauto. eauto.
- eapply find_bblock_tail; eauto.
- simpl. eauto.
- erewrite <- sp_val by eauto.
- eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved.
- eapply external_call_symbols_preserved; eauto. apply senv_preserved.
- eauto.
- econstructor; eauto.
- instantiate (2 := tf); instantiate (1 := x0).
- unfold nextblock, incrPC. rewrite Pregmap.gss.
- rewrite set_res_other. rewrite undef_regs_other_2. rewrite Pregmap.gso by congruence.
- rewrite <- H. simpl. econstructor; eauto.
- eapply code_tail_next_int; eauto.
- rewrite preg_notin_charact. intros. auto with asmgen.
- auto with asmgen.
- apply agree_nextblock. eapply agree_set_res; auto.
- eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto.
- apply Pregmap.gso; auto with asmgen.
- congruence.
-Qed.
-
-Lemma next_sep:
- forall rs m rs' m', rs = rs' -> m = m' -> Next rs m = Next rs' m'.
-Proof.
- congruence.
-Qed.
-
-Theorem step_simulation:
- forall S1 t S2, MB.step return_address_offset ge S1 t S2 ->
- forall S1' (MS: match_states S1 S1'),
- (exists S2', plus step tge S1' t S2' /\ match_states S2 S2')
- \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat.
-Proof.
- induction 1; intros.
-
-- (* bblock *)
- left. destruct (Machblock.exit bb) eqn:MBE; try destruct c0.
- all: try(inversion H0; subst; inv H2; eapply step_simulation_bblock;
- try (rewrite MBE; try discriminate); eauto).
- + (* MBbuiltin *)
- destruct (MB.body bb) eqn:MBB.
- * inv H. eapply step_simulation_builtin; eauto. rewrite MBE. eauto.
- * eapply match_states_split_builtin in MS; eauto.
- 2: rewrite MBB; discriminate.
- simpl split in MS.
- rewrite <- MBB in H.
- remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb1.
- assert (MB.body bb = MB.body bb1). { subst. simpl. auto. }
- rewrite H1 in H. subst.
- exploit step_simulation_bblock. eapply H.
- discriminate.
- simpl. constructor.
- eauto.
- intros (S2' & PLUS1 & MS').
- rewrite MBE in MS'.
- assert (exit_step return_address_offset ge (Some (MBbuiltin e l b))
- (MB.State sf f sp ({| MB.header := nil; MB.body := nil; MB.exit := Some (MBbuiltin e l b) |}::c)
- rs' m') t s').
- { inv H0. inv H3. econstructor. econstructor; eauto. }
- exploit step_simulation_builtin.
- 4: eapply MS'.
- all: simpl; eauto.
- intros (S3' & PLUS'' & MS'').
- exists S3'. split; eauto.
- eapply plus_trans. eapply PLUS1. eapply PLUS''. eauto.
- + inversion H0. subst. eapply step_simulation_bblock; try (rewrite MBE; try discriminate); eauto.
-
-- (* internal function *)
- inv MS.
- exploit functions_translated; eauto. intros [tf [A B]]. monadInv B.
- generalize EQ; intros EQ'. monadInv EQ'.
- destruct (zlt Ptrofs.max_unsigned (size_blocks x0.(fn_blocks))); inversion EQ1. clear EQ1. subst x0.
- unfold Mach.store_stack in *.
- exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl.
- intros [m1' [C D]].
- exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto.
- intros [m2' [F G]].
- simpl chunk_of_type in F.
- exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto.
- intros [m3' [P Q]].
- (* Execution of function prologue *)
- monadInv EQ0. (* rewrite transl_code'_transl_code in EQ1. *)
- set (tfbody := make_prologue f x0) in *.
- set (tf := {| fn_sig := MB.fn_sig f; fn_blocks := tfbody |}) in *.
- set (rs2 := rs0#FP <- (parent_sp s) #SP <- sp #RTMP <- Vundef).
- exploit (Pget_correct tge GPRA RA nil rs2 m2'); auto.
- intros (rs' & U' & V').
-(* exploit (exec_straight_through_singleinst); eauto.
- intro W'. remember (nextblock _ rs') as rs''. *)
- exploit (storeind_ptr_correct tge SP (fn_retaddr_ofs f) GPRA nil rs' m2').
- rewrite chunk_of_Tptr in P.
- assert (rs' GPRA = rs0 RA). { apply V'. }
- assert (rs' SP = rs2 SP). { apply V'; discriminate. }
- rewrite H4. rewrite H3.
- (* change (rs' GPRA) with (rs0 RA). *)
- rewrite ATLR.
- change (rs2 SP) with sp. eexact P.
- intros (rs3 & U & V).
-(* exploit (exec_straight_through_singleinst); eauto.
- intro W. *)
- assert (EXEC_PROLOGUE: exists rs3',
- exec_straight_blocks tge tf
- tf.(fn_blocks) rs0 m'
- x0 rs3' m3'
- /\ forall r, r <> PC -> rs3' r = rs3 r).
- { eexists. split.
- - change (fn_blocks tf) with tfbody; unfold tfbody.
- econstructor; eauto. unfold exec_bblock. simpl exec_body.
- rewrite C. fold sp. rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. simpl in F. rewrite F.
- Simpl. unfold parexec_store_offset. rewrite Ptrofs.of_int64_to_int64. unfold eval_offset.
- rewrite chunk_of_Tptr in P. Simpl. rewrite ATLR. unfold Mptr in P. assert (Archi.ptr64 = true) by auto. 2: auto. rewrite H3 in P. rewrite P.
- simpl. apply next_sep; eauto. reflexivity.
- - intros. destruct V' as (V'' & V'). destruct r.
- + Simpl.
- destruct (gpreg_eq g0 GPR16). { subst. Simpl. rewrite V; try discriminate. rewrite V''. subst rs2. Simpl. }
- destruct (gpreg_eq g0 GPR32). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. }
- destruct (gpreg_eq g0 GPR12). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. }
- destruct (gpreg_eq g0 GPR17). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. }
- Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. { destruct g0; try discriminate. contradiction. }
- + Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl.
- + contradiction.
- } destruct EXEC_PROLOGUE as (rs3' & EXEC_PROLOGUE & Heqrs3').
- exploit exec_straight_steps_2; eauto using functions_transl.
- simpl fn_blocks. simpl fn_blocks in g. omega. constructor.
- intros (ofs' & X & Y).
- left; exists (State rs3' m3'); split.
- eapply exec_straight_steps_1; eauto.
- simpl fn_blocks. simpl fn_blocks in g. omega.
- constructor.
- econstructor; eauto.
- rewrite X; econstructor; eauto.
- apply agree_exten with rs2; eauto with asmgen.
- unfold rs2.
- apply agree_set_other; auto with asmgen.
- apply agree_change_sp with (parent_sp s).
- apply agree_undef_regs with rs0. auto.
-Local Transparent destroyed_at_function_entry.
- simpl; intros; Simpl.
- unfold sp; congruence.
-
- intros.
- assert (r <> RTMP). { contradict H3; rewrite H3; unfold data_preg; auto. }
- rewrite Heqrs3'. Simpl. rewrite V. inversion V'. rewrite H6. auto.
- assert (r <> GPRA). { contradict H3; rewrite H3; unfold data_preg; auto. }
- assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. }
- (* rewrite H8; auto. *)
- contradict H3; rewrite H3; unfold data_preg; auto.
- contradict H3; rewrite H3; unfold data_preg; auto.
- contradict H3; rewrite H3; unfold data_preg; auto.
- contradict H3; rewrite H3; unfold data_preg; auto.
- intros. rewrite Heqrs3'. rewrite V by auto with asmgen.
- assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. }
- rewrite H4 by auto with asmgen. reflexivity. discriminate.
-- (* external function *)
- inv MS.
- exploit functions_translated; eauto.
- intros [tf [A B]]. simpl in B. inv B.
- exploit extcall_arguments_match; eauto.
- intros [args' [C D]].
- exploit external_call_mem_extends; eauto.
- intros [res' [m2' [P [Q [R S]]]]].
- left; econstructor; split.
- apply plus_one. eapply exec_step_external; eauto.
- eapply external_call_symbols_preserved; eauto. apply senv_preserved.
- econstructor; eauto.
- unfold loc_external_result.
- apply agree_set_other; auto.
- apply agree_set_pair; auto.
- apply agree_undef_caller_save_regs; auto.
-
-- (* return *)
- inv MS.
- inv STACKS. simpl in *.
- right. split. omega. split. auto.
- rewrite <- ATPC in H5.
- econstructor; eauto. congruence.
-Qed.
-
-Lemma transf_initial_states:
- forall st1, MB.initial_state prog st1 ->
- exists st2, AB.initial_state tprog st2 /\ match_states st1 st2.
-Proof.
- intros. inversion H. unfold ge0 in *.
- econstructor; split.
- econstructor.
- eapply (Genv.init_mem_transf_partial TRANSF); eauto.
- replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero)
- with (Vptr fb Ptrofs.zero).
- econstructor; eauto.
- constructor.
- apply Mem.extends_refl.
- split. auto. simpl. unfold Vnullptr; destruct Archi.ptr64; congruence.
- intros. rewrite Mach.Regmap.gi. auto.
- unfold Genv.symbol_address.
- rewrite (match_program_main TRANSF).
- rewrite symbols_preserved.
- unfold ge; rewrite H1. auto.
-Qed.
-
-Lemma transf_final_states:
- forall st1 st2 r,
- match_states st1 st2 -> MB.final_state st1 r -> AB.final_state st2 r.
-Proof.
- intros. inv H0. inv H. constructor. assumption.
- compute in H1. inv H1.
- generalize (preg_val _ _ _ R0 AG). rewrite H2. intros LD; inv LD. auto.
-Qed.
-
-Definition return_address_offset : Machblock.function -> Machblock.code -> ptrofs -> Prop :=
- Asmblockgenproof0.return_address_offset.
-
-Theorem transf_program_correct:
- forward_simulation (MB.semantics return_address_offset prog) (Asmblock.semantics tprog).
-Proof.
- eapply forward_simulation_star with (measure := measure).
- - apply senv_preserved.
- - eexact transf_initial_states.
- - eexact transf_final_states.
- - exact step_simulation.
-Qed.
-
-End PRESERVATION.
+(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Correctness proof for RISC-V generation: main proof. *) + +Require Import Coqlib Errors. +Require Import Integers Floats AST Linking. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import Op Locations Machblock Conventions Asmblock. +Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1 Asmblockprops. +Require Import Axioms. + +Module MB := Machblock. +Module AB := Asmvliw. + +Definition match_prog (p: Machblock.program) (tp: Asmvliw.program) := + match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. + +Lemma transf_program_match: + forall p tp, transf_program p = OK tp -> match_prog p tp. +Proof. + intros. eapply match_transform_partial_program; eauto. +Qed. + +Section PRESERVATION. + +Variable prog: Machblock.program. +Variable tprog: Asmvliw.program. +Hypothesis TRANSF: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma symbols_preserved: + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof (Genv.find_symbol_match TRANSF). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). + +Lemma functions_translated: + forall b f, + Genv.find_funct_ptr ge b = Some f -> + exists tf, + Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_ptr_transf_partial TRANSF). + +Lemma functions_transl: + forall fb f tf, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transf_function f = OK tf -> + Genv.find_funct_ptr tge fb = Some (Internal tf). +Proof. + intros. exploit functions_translated; eauto. intros [tf' [A B]]. + monadInv B. rewrite H0 in EQ; inv EQ; auto. +Qed. + +Lemma transf_function_no_overflow: + forall f tf, + transf_function f = OK tf -> size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned. +Proof. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. + omega. +Qed. + +Section TRANSL_LABEL. (* Lemmas on translation of MB.is_label into AB.is_label *) + +Lemma gen_bblocks_label: + forall hd bdy ex tbb tc, + gen_bblocks hd bdy ex = tbb::tc -> + header tbb = hd. +Proof. + intros until tc. intros GENB. unfold gen_bblocks in GENB. + destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy. + all: inv GENB; simpl; auto. +Qed. + +Lemma gen_bblocks_label2: + forall hd bdy ex tbb1 tbb2, + gen_bblocks hd bdy ex = tbb1::tbb2::nil -> + header tbb2 = nil. +Proof. + intros until tbb2. intros GENB. unfold gen_bblocks in GENB. + destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy. + all: inv GENB; simpl; auto. +Qed. + +Remark in_dec_transl: + forall lbl hd, + (if in_dec lbl hd then true else false) = (if MB.in_dec lbl hd then true else false). +Proof. + intros. destruct (in_dec lbl hd), (MB.in_dec lbl hd). all: tauto. +Qed. + +Lemma transl_is_label: + forall lbl bb tbb f ep tc, + transl_block f bb ep = OK (tbb::tc) -> + is_label lbl tbb = MB.is_label lbl bb. +Proof. + intros until tc. intros TLB. + destruct tbb as [thd tbdy tex]; simpl in *. + monadInv TLB. + unfold is_label. simpl. + apply gen_bblocks_label in H0. simpl in H0. subst. + rewrite in_dec_transl. auto. +Qed. + +Lemma transl_is_label_false2: + forall lbl bb f ep tbb1 tbb2, + transl_block f bb ep = OK (tbb1::tbb2::nil) -> + is_label lbl tbb2 = false. +Proof. + intros until tbb2. intros TLB. + destruct tbb2 as [thd tbdy tex]; simpl in *. + monadInv TLB. apply gen_bblocks_label2 in H0. simpl in H0. subst. + apply is_label_correct_false. simpl. auto. +Qed. + +Lemma transl_is_label2: + forall f bb ep tbb1 tbb2 lbl, + transl_block f bb ep = OK (tbb1::tbb2::nil) -> + is_label lbl tbb1 = MB.is_label lbl bb + /\ is_label lbl tbb2 = false. +Proof. + intros. split. eapply transl_is_label; eauto. eapply transl_is_label_false2; eauto. +Qed. + +Lemma transl_block_nonil: + forall f c ep tc, + transl_block f c ep = OK tc -> + tc <> nil. +Proof. + intros. monadInv H. unfold gen_bblocks. + destruct (extract_ctl x0); try destruct c0; try destruct x; try destruct i. + all: discriminate. +Qed. + +Lemma transl_block_limit: forall f bb ep tbb1 tbb2 tbb3 tc, + ~transl_block f bb ep = OK (tbb1 :: tbb2 :: tbb3 :: tc). +Proof. + intros. intro. monadInv H. + unfold gen_bblocks in H0. + destruct (extract_ctl x0); try destruct x; try destruct c; try destruct i. + all: discriminate. +Qed. + +Lemma find_label_transl_false: + forall x f lbl bb ep x', + transl_block f bb ep = OK x -> + MB.is_label lbl bb = false -> + find_label lbl (x++x') = find_label lbl x'. +Proof. + intros until x'. intros TLB MBis; simpl; auto. + destruct x as [|x0 x1]; simpl; auto. + destruct x1 as [|x1 x2]; simpl; auto. + - erewrite <- transl_is_label in MBis; eauto. rewrite MBis. auto. + - destruct x2 as [|x2 x3]; simpl; auto. + + erewrite <- transl_is_label in MBis; eauto. rewrite MBis. + erewrite transl_is_label_false2; eauto. + + apply transl_block_limit in TLB. destruct TLB. +Qed. + +Lemma transl_blocks_label: + forall lbl f c tc ep, + transl_blocks f c ep = OK tc -> + match MB.find_label lbl c with + | None => find_label lbl tc = None + | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_blocks f c' false = OK tc' + end. +Proof. + induction c; simpl; intros. + inv H. auto. + monadInv H. + destruct (MB.is_label lbl a) eqn:MBis. + - destruct x as [|tbb tc]. { apply transl_block_nonil in EQ. contradiction. } + simpl find_label. exploit transl_is_label; eauto. intros ABis. rewrite MBis in ABis. + rewrite ABis. + eexists. eexists. split; eauto. simpl transl_blocks. + assert (MB.header a <> nil). + { apply MB.is_label_correct_true in MBis. + destruct (MB.header a). contradiction. discriminate. } + destruct (MB.header a); try contradiction. + rewrite EQ. simpl. rewrite EQ1. simpl. auto. + - apply IHc in EQ1. destruct (MB.find_label lbl c). + + destruct EQ1 as (tc' & FIND & TLBS). exists tc'; eexists; auto. + erewrite find_label_transl_false; eauto. + + erewrite find_label_transl_false; eauto. +Qed. + +Lemma find_label_nil: + forall bb lbl c, + header bb = nil -> + find_label lbl (bb::c) = find_label lbl c. +Proof. + intros. destruct bb as [hd bdy ex]; simpl in *. subst. + assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false). + { erewrite <- is_label_correct_false. simpl. auto. } + rewrite H. auto. +Qed. + +Theorem transl_find_label: + forall lbl f tf, + transf_function f = OK tf -> + match MB.find_label lbl f.(MB.fn_code) with + | None => find_label lbl tf.(fn_blocks) = None + | Some c => exists tc, find_label lbl tf.(fn_blocks) = Some tc /\ transl_blocks f c false = OK tc + end. +Proof. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks x))); inv EQ0. clear g. + monadInv EQ. unfold make_prologue. simpl fn_blocks. repeat (rewrite find_label_nil); simpl; auto. + eapply transl_blocks_label; eauto. +Qed. + +End TRANSL_LABEL. + +(** A valid branch in a piece of Machblock code translates to a valid ``go to'' + transition in the generated Asmblock code. *) + +Lemma find_label_goto_label: + forall f tf lbl rs m c' b ofs, + Genv.find_funct_ptr ge b = Some (Internal f) -> + transf_function f = OK tf -> + rs PC = Vptr b ofs -> + MB.find_label lbl f.(MB.fn_code) = Some c' -> + exists tc', exists rs', + goto_label tf lbl rs m = Next rs' m + /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc' + /\ forall r, r <> PC -> rs'#r = rs#r. +Proof. + intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2. + intros (tc & A & B). + exploit label_pos_code_tail; eauto. instantiate (1 := 0). + intros [pos' [P [Q R]]]. + exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))). + split. unfold goto_label. unfold par_goto_label. rewrite P. rewrite H1. auto. + split. rewrite Pregmap.gss. constructor; auto. + rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. + auto. omega. + generalize (transf_function_no_overflow _ _ H0). omega. + intros. apply Pregmap.gso; auto. +Qed. + +(** Existence of return addresses *) + +Lemma return_address_exists: + forall b f c, is_tail (b :: c) f.(MB.fn_code) -> + exists ra, return_address_offset f c ra. +Proof. + intros. eapply Asmblockgenproof0.return_address_exists; eauto. + +- intros. monadInv H0. + destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. monadInv EQ. simpl. + exists x; exists true; split; auto. + repeat constructor. +- exact transf_function_no_overflow. +Qed. + +(** * Proof of semantic preservation *) + +(** Semantic preservation is proved using a complex simulation diagram + of the following form. +<< + MB.step + ----------------------------------------> + header body exit + st1 -----> st2 -----> st3 ------------------> st4 + | | | | + | (A) | (B) | (C) | + match_codestate | | | | + | header | body1 | body2 | match_states + cs1 -----> cs2 -----> cs3 ------> cs4 | + | / \ exit | + match_asmstate | --------------- --->--- | + | / match_asmstate \ | + st'1 ---------------------------------------> st'2 + AB.step * +>> + The invariant between each MB.step/AB.step is the [match_states] predicate below. + However, we also need to introduce an intermediary state [Codestate] which allows + us to reason on a finer grain, executing header, body and exit separately. + + This [Codestate] consists in a state like [Asmblock.State], except that the + code is directly stored in the state, much like [Machblock.State]. It also features + additional useful elements to keep track of while executing a bblock. +*) + +Remark preg_of_not_FP: forall r, negb (mreg_eq r MFP) = true -> IR FP <> preg_of r. +Proof. + intros. change (IR FP) with (preg_of MFP). red; intros. + exploit preg_of_injective; eauto. intros; subst r; discriminate. +Qed. + +Inductive match_states: Machblock.state -> Asmvliw.state -> Prop := + | match_states_intro: + forall s fb sp c ep ms m m' rs f tf tc + (STACKS: match_stack ge s) + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (MEXT: Mem.extends m m') + (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc) + (AG: agree ms sp rs) + (DXP: ep = true -> rs#FP = parent_sp s), + match_states (Machblock.State s fb sp c ms m) + (Asmvliw.State rs m') + | match_states_call: + forall s fb ms m m' rs + (STACKS: match_stack ge s) + (MEXT: Mem.extends m m') + (AG: agree ms (parent_sp s) rs) + (ATPC: rs PC = Vptr fb Ptrofs.zero) + (ATLR: rs RA = parent_ra s), + match_states (Machblock.Callstate s fb ms m) + (Asmvliw.State rs m') + | match_states_return: + forall s ms m m' rs + (STACKS: match_stack ge s) + (MEXT: Mem.extends m m') + (AG: agree ms (parent_sp s) rs) + (ATPC: rs PC = parent_ra s), + match_states (Machblock.Returnstate s ms m) + (Asmvliw.State rs m'). + +Record codestate := + Codestate { pstate: state; (**r projection to Asmblock.state *) + pheader: list label; + pbody1: list basic; (**r list of basic instructions coming from the translation of the Machblock body *) + pbody2: list basic; (**r list of basic instructions coming from the translation of the Machblock exit *) + pctl: option control; (**r exit instruction, coming from the translation of the Machblock exit *) + ep: bool; (**r reflects the [ep] variable used in the translation *) + rem: list AB.bblock; (**r remaining bblocks to execute *) + cur: bblock (**r current bblock to execute - to keep track of its size when incrementing PC *) + }. + +(* The part that deals with Machblock <-> Codestate agreement + * Note about DXP: the property of [ep] only matters if the current block doesn't have a header, hence the condition *) +Inductive match_codestate fb: Machblock.state -> codestate -> Prop := + | match_codestate_intro: + forall s sp ms m rs0 m0 f tc ep c bb tbb tbc tbi + (STACKS: match_stack ge s) + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (MEXT: Mem.extends m m0) + (TBC: transl_basic_code f (MB.body bb) (if MB.header bb then ep else false) = OK tbc) + (TIC: transl_instr_control f (MB.exit bb) = OK tbi) + (TBLS: transl_blocks f c false = OK tc) + (AG: agree ms sp rs0) + (DXP: (if MB.header bb then ep else false) = true -> rs0#FP = parent_sp s) + , + match_codestate fb (Machblock.State s fb sp (bb::c) ms m) + {| pstate := (Asmvliw.State rs0 m0); + pheader := (MB.header bb); + pbody1 := tbc; + pbody2 := extract_basic tbi; + pctl := extract_ctl tbi; + ep := ep; + rem := tc; + cur := tbb + |} +. + +(* The part ensuring that the code in Codestate actually resides at [rs PC] *) +Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop := + | match_asmstate_some: + forall rs f tf tc m tbb ofs ep tbdy tex lhd + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (TRANSF: transf_function f = OK tf) + (PCeq: rs PC = Vptr fb ofs) + (TAIL: code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (tbb::tc)) + , + match_asmstate fb + {| pstate := (Asmvliw.State rs m); + pheader := lhd; + pbody1 := tbdy; + pbody2 := extract_basic tex; + pctl := extract_ctl tex; + ep := ep; + rem := tc; + cur := tbb |} + (Asmvliw.State rs m) +. + +(* Useful for dealing with the many cases in some proofs *) +Ltac exploreInst := + repeat match goal with + | [ H : match ?var with | _ => _ end = _ |- _ ] => destruct var + | [ H : OK _ = OK _ |- _ ] => monadInv H + | [ |- context[if ?b then _ else _] ] => destruct b + | [ |- context[match ?m with | _ => _ end] ] => destruct m + | [ |- context[match ?m as _ return _ with | _ => _ end]] => destruct m + | [ H : bind _ _ = OK _ |- _ ] => monadInv H + | [ H : Error _ = OK _ |- _ ] => inversion H + end. + +(** Some translation properties *) + +Lemma transl_blocks_nonil: + forall f bb c tc ep, + transl_blocks f (bb::c) ep = OK tc -> + exists tbb tc', tc = tbb :: tc'. +Proof. + intros until ep0. intros TLBS. monadInv TLBS. monadInv EQ. unfold gen_bblocks. + destruct (extract_ctl x2). + - destruct c0; destruct i; simpl; eauto. destruct x1; simpl; eauto. + - destruct x1; simpl; eauto. +Qed. + +Lemma no_builtin_preserved: + forall f ex x2, + (forall ef args res, ex <> Some (MBbuiltin ef args res)) -> + transl_instr_control f ex = OK x2 -> + (exists i, extract_ctl x2 = Some (PCtlFlow i)) + \/ extract_ctl x2 = None. +Proof. + intros until x2. intros Hbuiltin TIC. + destruct ex. + - destruct c. + (* MBcall *) + + simpl in TIC. exploreInst; simpl; eauto. + (* MBtailcall *) + + simpl in TIC. exploreInst; simpl; eauto. + (* MBbuiltin *) + + assert (H: Some (MBbuiltin e l b) <> Some (MBbuiltin e l b)). + apply Hbuiltin. contradict H; auto. + (* MBgoto *) + + simpl in TIC. exploreInst; simpl; eauto. + (* MBcond *) + + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; simpl; eauto. + * unfold transl_opt_compuimm. exploreInst; simpl; eauto. + * unfold transl_opt_compluimm. exploreInst; simpl; eauto. + * unfold transl_comp_float64. exploreInst; simpl; eauto. + * unfold transl_comp_notfloat64. exploreInst; simpl; eauto. + * unfold transl_comp_float32. exploreInst; simpl; eauto. + * unfold transl_comp_notfloat32. exploreInst; simpl; eauto. + (* MBjumptable *) + + simpl in TIC. exploreInst; simpl; eauto. + (* MBreturn *) + + simpl in TIC. monadInv TIC. simpl. eauto. + - monadInv TIC. simpl; auto. +Qed. + +Lemma transl_blocks_distrib: + forall c f bb tbb tc ep, + transl_blocks f (bb::c) ep = OK (tbb::tc) + -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) + -> transl_block f bb (if MB.header bb then ep else false) = OK (tbb :: nil) + /\ transl_blocks f c false = OK tc. +Proof. + intros until ep0. intros TLBS Hbuiltin. + destruct bb as [hd bdy ex]. + monadInv TLBS. monadInv EQ. + exploit no_builtin_preserved; eauto. intros Hectl. destruct Hectl. + - destruct H as [i Hectl]. + unfold gen_bblocks in H0. rewrite Hectl in H0. inv H0. + simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. + unfold gen_bblocks. rewrite Hectl. auto. + - unfold gen_bblocks in H0. rewrite H in H0. + destruct x1 as [|bi x1]. + + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. + unfold gen_bblocks. rewrite H. auto. + + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. + unfold gen_bblocks. rewrite H. auto. +Qed. + +Lemma gen_bblocks_nobuiltin: + forall thd tbdy tex tbb, + (tbdy <> nil \/ extract_ctl tex <> None) -> + (forall ef args res, extract_ctl tex <> Some (PExpand (Pbuiltin ef args res))) -> + gen_bblocks thd tbdy tex = tbb :: nil -> + header tbb = thd + /\ body tbb = tbdy ++ extract_basic tex + /\ exit tbb = extract_ctl tex. +Proof. + intros until tbb. intros Hnonil Hnobuiltin GENB. unfold gen_bblocks in GENB. + destruct (extract_ctl tex) eqn:ECTL. + - destruct c. + + destruct i; try (inv GENB; simpl; auto; fail). + assert False. eapply Hnobuiltin. eauto. destruct H. + + inv GENB. simpl. auto. + - inversion Hnonil. + + destruct tbdy as [|bi tbdy]; try (contradict H; simpl; auto; fail). inv GENB. auto. + + contradict H; simpl; auto. +Qed. + +Lemma transl_instr_basic_nonil: + forall k f bi ep x, + transl_instr_basic f bi ep k = OK x -> + x <> nil. +Proof. + intros until x. intros TIB. + destruct bi. + - simpl in TIB. unfold loadind in TIB. exploreInst; try discriminate. + - simpl in TIB. unfold storeind in TIB. exploreInst; try discriminate. + - simpl in TIB. monadInv TIB. unfold loadind in EQ. exploreInst; try discriminate. + - simpl in TIB. unfold transl_op in TIB. exploreInst; try discriminate. + unfold transl_cond_op in EQ0. exploreInst; try discriminate. + unfold transl_cond_float64. exploreInst; try discriminate. + unfold transl_cond_notfloat64. exploreInst; try discriminate. + unfold transl_cond_float32. exploreInst; try discriminate. + unfold transl_cond_notfloat32. exploreInst; try discriminate. + - simpl in TIB. unfold transl_load in TIB. exploreInst; try discriminate. + all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate. + - simpl in TIB. unfold transl_store in TIB. exploreInst; try discriminate. + all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate. +Qed. + +Lemma transl_basic_code_nonil: + forall bdy f x ep, + bdy <> nil -> + transl_basic_code f bdy ep = OK x -> + x <> nil. +Proof. + induction bdy as [|bi bdy]. + intros. contradict H0; auto. + destruct bdy as [|bi2 bdy]. + - clear IHbdy. intros f x b _ TBC. simpl in TBC. eapply transl_instr_basic_nonil; eauto. + - intros f x b Hnonil TBC. remember (bi2 :: bdy) as bdy'. + monadInv TBC. + assert (x0 <> nil). + eapply IHbdy; eauto. subst bdy'. discriminate. + eapply transl_instr_basic_nonil; eauto. +Qed. + +Lemma transl_instr_control_nonil: + forall ex f x, + ex <> None -> + transl_instr_control f ex = OK x -> + extract_ctl x <> None. +Proof. + intros ex f x Hnonil TIC. + destruct ex as [ex|]. + - clear Hnonil. destruct ex. + all: try (simpl in TIC; exploreInst; discriminate). + + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; try discriminate. + * unfold transl_opt_compuimm. exploreInst; try discriminate. + * unfold transl_opt_compluimm. exploreInst; try discriminate. + * unfold transl_comp_float64. exploreInst; try discriminate. + * unfold transl_comp_notfloat64. exploreInst; try discriminate. + * unfold transl_comp_float32. exploreInst; try discriminate. + * unfold transl_comp_notfloat32. exploreInst; try discriminate. + - contradict Hnonil; auto. +Qed. + +Lemma transl_instr_control_nobuiltin: + forall f ex x, + (forall ef args res, ex <> Some (MBbuiltin ef args res)) -> + transl_instr_control f ex = OK x -> + (forall ef args res, extract_ctl x <> Some (PExpand (Pbuiltin ef args res))). +Proof. + intros until x. intros Hnobuiltin TIC. intros until res. + unfold transl_instr_control in TIC. exploreInst. + all: try discriminate. + - assert False. eapply Hnobuiltin; eauto. destruct H. + - unfold transl_cbranch in TIC. exploreInst. + all: try discriminate. + * unfold transl_opt_compuimm. exploreInst. all: try discriminate. + * unfold transl_opt_compluimm. exploreInst. all: try discriminate. + * unfold transl_comp_float64. exploreInst; try discriminate. + * unfold transl_comp_notfloat64. exploreInst; try discriminate. + * unfold transl_comp_float32. exploreInst; try discriminate. + * unfold transl_comp_notfloat32. exploreInst; try discriminate. +Qed. + +(* Proving that one can decompose a [match_state] relation into a [match_codestate] + and a [match_asmstate], along with some helpful properties tying both relations together *) + +Theorem match_state_codestate: + forall mbs abs s fb sp bb c ms m, + (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + (MB.body bb <> nil \/ MB.exit bb <> None) -> + mbs = (Machblock.State s fb sp (bb::c) ms m) -> + match_states mbs abs -> + exists cs fb f tbb tc ep, + match_codestate fb mbs cs /\ match_asmstate fb cs abs + /\ Genv.find_funct_ptr ge fb = Some (Internal f) + /\ transl_blocks f (bb::c) ep = OK (tbb::tc) + /\ body tbb = pbody1 cs ++ pbody2 cs + /\ exit tbb = pctl cs + /\ cur cs = tbb /\ rem cs = tc + /\ pstate cs = abs. +Proof. + intros until m. intros Hnobuiltin Hnotempty Hmbs MS. subst. inv MS. + inv AT. clear H0. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. + exploit transl_blocks_distrib; eauto. intros (TLB & TLBS). clear H2. + monadInv TLB. exploit gen_bblocks_nobuiltin; eauto. + { inversion Hnotempty. + - destruct (MB.body bb) as [|bi bdy]; try (contradict H0; simpl; auto; fail). + left. eapply transl_basic_code_nonil; eauto. + - destruct (MB.exit bb) as [ei|]; try (contradict H0; simpl; auto; fail). + right. eapply transl_instr_control_nonil; eauto. } + eapply transl_instr_control_nobuiltin; eauto. + intros (Hth & Htbdy & Htexit). + exists {| pstate := (State rs m'); pheader := (Machblock.header bb); pbody1 := x; pbody2 := extract_basic x0; + pctl := extract_ctl x0; ep := ep0; rem := tc'; cur := tbb |}, fb, f, tbb, tc', ep0. + repeat split. 1-2: econstructor; eauto. + { destruct (MB.header bb). eauto. discriminate. } eauto. + unfold transl_blocks. fold transl_blocks. unfold transl_block. rewrite EQ. simpl. rewrite EQ1; simpl. + rewrite TLBS. simpl. rewrite H2. + all: simpl; auto. +Qed. + +Definition mb_remove_body (bb: MB.bblock) := + {| MB.header := MB.header bb; MB.body := nil; MB.exit := MB.exit bb |}. + +Lemma exec_straight_pnil: + forall c rs1 m1 rs2 m2, + exec_straight tge c rs1 m1 (Pnop ::g nil) rs2 m2 -> + exec_straight tge c rs1 m1 nil rs2 m2. +Proof. + intros. eapply exec_straight_trans. eapply H. econstructor; eauto. +Qed. + +Lemma transl_block_nobuiltin: + forall f bb ep tbb, + (MB.body bb <> nil \/ MB.exit bb <> None) -> + (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + transl_block f bb ep = OK (tbb :: nil) -> + exists c c', + transl_basic_code f (MB.body bb) ep = OK c + /\ transl_instr_control f (MB.exit bb) = OK c' + /\ body tbb = c ++ extract_basic c' + /\ exit tbb = extract_ctl c'. +Proof. + intros until tbb. intros Hnonil Hnobuiltin TLB. monadInv TLB. destruct Hnonil. + - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto. + left. eapply transl_basic_code_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto. + - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto. + right. eapply transl_instr_control_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto. +Qed. + +Lemma nextblock_preserves: + forall rs rs' bb r, + rs' = nextblock bb rs -> + data_preg r = true -> + rs r = rs' r. +Proof. + intros. destruct r; try discriminate. + subst. Simpl. +Qed. + +Remark cons3_app {A: Type}: + forall a b c (l: list A), + a :: b :: c :: l = (a :: b :: c :: nil) ++ l. +Proof. + intros. simpl. auto. +Qed. + +Lemma exec_straight_opt_body2: + forall c rs1 m1 c' rs2 m2, + exec_straight_opt tge c rs1 m1 c' rs2 m2 -> + exists body, + exec_body tge body rs1 m1 = Next rs2 m2 + /\ (basics_to_code body) ++g c' = c. +Proof. + intros until m2. intros EXES. + inv EXES. + - exists nil. split; auto. + - eapply exec_straight_body2. auto. +Qed. + +Lemma extract_basics_to_code: + forall lb c, + extract_basic (basics_to_code lb ++ c) = lb ++ extract_basic c. +Proof. + induction lb; intros; simpl; congruence. +Qed. + +Lemma extract_ctl_basics_to_code: + forall lb c, + extract_ctl (basics_to_code lb ++ c) = extract_ctl c. +Proof. + induction lb; intros; simpl; congruence. +Qed. + +(* See (C) in the diagram. The proofs are mostly adapted from the previous Mach->Asm proofs, but are + unfortunately quite cumbersome. To reproduce them, it's best to have a Coq IDE with you and see by + yourself the steps *) +Theorem step_simu_control: + forall bb' fb fn s sp c ms' m' rs2 m2 t S'' rs1 m1 tbb tbdy2 tex cs2, + MB.body bb' = nil -> + (forall ef args res, MB.exit bb' <> Some (MBbuiltin ef args res)) -> + Genv.find_funct_ptr tge fb = Some (Internal fn) -> + pstate cs2 = (Asmvliw.State rs2 m2) -> + pbody1 cs2 = nil -> pbody2 cs2 = tbdy2 -> pctl cs2 = tex -> + cur cs2 = tbb -> + match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 -> + match_asmstate fb cs2 (Asmvliw.State rs1 m1) -> + exit_step return_address_offset ge (MB.exit bb') (MB.State s fb sp (bb'::c) ms' m') t S'' -> + (exists rs3 m3 rs4 m4, + exec_body tge tbdy2 rs2 m2 = Next rs3 m3 + /\ exec_control_rel tge fn tex tbb rs3 m3 rs4 m4 + /\ match_states S'' (State rs4 m4)). +Proof. + intros until cs2. intros Hbody Hbuiltin FIND Hpstate Hpbody1 Hpbody2 Hpctl Hcur MCS MAS ESTEP. + inv ESTEP. + - inv MCS. inv MAS. simpl in *. + inv Hpstate. + destruct ctl. + + (* MBcall *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + destruct s1 as [rf|fid]; simpl in H7. + * (* Indirect call *) + monadInv H1. + assert (ms' rf = Vptr f' Ptrofs.zero). + { unfold find_function_ptr in H14. destruct (ms' rf); try discriminate. + revert H14; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } + assert (rs2 x = Vptr f' Ptrofs.zero). + { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. } + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. + remember (Ptrofs.add _ _) as ofs'. + assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc). + { econstructor; eauto. } + assert (f1 = f) by congruence. subst f1. + exploit return_address_offset_correct; eauto. intros; subst ra. + + repeat eexists. + rewrite H6. econstructor; eauto. + rewrite H7. econstructor; eauto. + econstructor; eauto. + econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. + simpl. Simpl. rewrite PCeq. rewrite Heqofs'. simpl. auto. + + * (* Direct call *) + monadInv H1. + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. + remember (Ptrofs.add _ _) as ofs'. + assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc). + econstructor; eauto. + assert (f1 = f) by congruence. subst f1. + exploit return_address_offset_correct; eauto. intros; subst ra. + repeat eexists. + rewrite H6. econstructor; eauto. + rewrite H7. econstructor; eauto. + econstructor; eauto. + econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. + Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. simpl in H14. rewrite H14. auto. + Simpl. simpl. subst. Simpl. simpl. unfold Val.offset_ptr. rewrite PCeq. auto. + + (* MBtailcall *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + exploit Mem.loadv_extends. eauto. eexact H15. auto. simpl. intros [parent' [A B]]. + destruct s1 as [rf|fid]; simpl in H13. + * monadInv H1. + assert (ms' rf = Vptr f' Ptrofs.zero). + { destruct (ms' rf); try discriminate. revert H13. predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } + assert (rs2 x = Vptr f' Ptrofs.zero). + { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. } + + assert (f = f1) by congruence. subst f1. clear FIND1. clear H14. + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_body; eauto. + { simpl. eauto. } + intros EXEB. + repeat eexists. + rewrite H6. simpl extract_basic. eauto. + rewrite H7. simpl extract_ctl. simpl. reflexivity. + econstructor; eauto. + { apply agree_set_other. + - econstructor; auto with asmgen. + + apply V. + + intro r. destruct r; apply V; auto. + - eauto with asmgen. } + assert (IR x <> IR GPR12 /\ IR x <> IR GPR32 /\ IR x <> IR GPR16). + { clear - EQ. destruct x; repeat split; try discriminate. + all: unfold ireg_of in EQ; destruct rf; try discriminate. } + Simpl. inv H1. inv H3. rewrite Z; auto; try discriminate. + * monadInv H1. assert (f = f1) by congruence. subst f1. clear FIND1. clear H14. + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_body; eauto. + simpl. eauto. + intros EXEB. + repeat eexists. + rewrite H6. simpl extract_basic. eauto. + rewrite H7. simpl extract_ctl. simpl. reflexivity. + econstructor; eauto. + { apply agree_set_other. + - econstructor; auto with asmgen. + + apply V. + + intro r. destruct r; apply V; auto. + - eauto with asmgen. } + { Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H13. auto. } + + (* MBbuiltin (contradiction) *) + assert (MB.exit bb' <> Some (MBbuiltin e l b)) by (apply Hbuiltin). + rewrite <- H in H1. contradict H1; auto. + + (* MBgoto *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. assert (f1 = f) by congruence. subst f1. clear H11. + remember (nextblock tbb rs2) as rs2'. + exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND'. + assert (tf = fn) by congruence. subst tf. + exploit find_label_goto_label. + eauto. eauto. + instantiate (2 := rs2'). + { subst. unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. eauto. } + eauto. + intros (tc' & rs' & GOTO & AT2 & INV). + + eexists. eexists. repeat eexists. repeat split. + rewrite H6. simpl extract_basic. simpl. eauto. + rewrite H7. simpl extract_ctl. simpl. rewrite <- Heqrs2'. eauto. + econstructor; eauto. + rewrite Heqrs2' in INV. unfold nextblock, incrPC in INV. + eapply agree_exten; eauto with asmgen. + assert (forall r : preg, r <> PC -> rs' r = rs2 r). + { intros. destruct r. + - destruct g. all: rewrite INV; Simpl; auto. + - rewrite INV; Simpl; auto. + - contradiction. } + eauto with asmgen. + congruence. + + (* MBcond *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + * (* MBcond true *) + assert (f0 = f) by congruence. subst f0. + exploit eval_condition_lessdef. + eapply preg_vals; eauto. + all: eauto. + intros EC. + exploit transl_cbranch_correct_true; eauto. intros (rs' & jmp & A & B & C). + exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC). + assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. } + rewrite PCeq' in PCeq. + assert (f1 = f) by congruence. subst f1. + exploit find_label_goto_label. + 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs')). rewrite nextblock_pc. + unfold Val.offset_ptr. rewrite PCeq. eauto. + intros (tc' & rs3 & GOTOL & TLPC & Hrs3). + exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'. + assert (tf = fn) by congruence. subst tf. + + repeat eexists. + rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto. + rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto. + + econstructor; eauto. + eapply agree_exten with rs2; eauto with asmgen. + { intros. destruct r; try destruct g; try discriminate. + all: rewrite Hrs3; try discriminate; unfold nextblock, incrPC; Simpl. } + intros. discriminate. + + * (* MBcond false *) + assert (f0 = f) by congruence. subst f0. + exploit eval_condition_lessdef. + eapply preg_vals; eauto. + all: eauto. + intros EC. + + exploit transl_cbranch_correct_false; eauto. intros (rs' & jmp & A & B & C). + exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC). + assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. } + rewrite PCeq' in PCeq. + exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'. + assert (tf = fn) by congruence. subst tf. + + assert (NOOV: size_blocks fn.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. + + repeat eexists. + rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto. + rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto. + + econstructor; eauto. + unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. econstructor; eauto. + eapply agree_exten with rs2; eauto with asmgen. + { intros. destruct r; try destruct g; try discriminate. + all: rewrite <- C; try discriminate; unfold nextblock, incrPC; Simpl. } + intros. discriminate. + + (* MBjumptable *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + monadInv H1. + generalize (transf_function_no_overflow _ _ TRANSF0); intro NOOV. + assert (f1 = f) by congruence. subst f1. + exploit find_label_goto_label. 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs2) # GPR62 <- Vundef # GPR63 <- Vundef). + unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. reflexivity. + exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND3. assert (fn = tf) by congruence. subst fn. + + intros [tc' [rs' [A [B C]]]]. + exploit ireg_val; eauto. rewrite H13. intros LD; inv LD. + + repeat eexists. + rewrite H6. simpl extract_basic. simpl. eauto. + rewrite H7. simpl extract_ctl. simpl. Simpl. rewrite <- H1. unfold Mach.label in H14. unfold label. rewrite H14. eapply A. + econstructor; eauto. + eapply agree_undef_regs; eauto. intros. rewrite C; auto with asmgen. + { assert (destroyed_by_jumptable = R62 :: R63 :: nil) by auto. rewrite H2 in H0. simpl in H0. inv H0. + destruct (preg_eq r' GPR63). subst. contradiction. + destruct (preg_eq r' GPR62). subst. contradiction. + destruct r'; Simpl. } + discriminate. + + (* MBreturn *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_body; eauto. + simpl. eauto. + intros EXEB. + assert (f1 = f) by congruence. subst f1. + + repeat eexists. + rewrite H6. simpl extract_basic. eauto. + rewrite H7. simpl extract_ctl. simpl. reflexivity. + econstructor; eauto. + unfold nextblock, incrPC. repeat apply agree_set_other; auto with asmgen. + + - inv MCS. inv MAS. simpl in *. subst. inv Hpstate. + destruct bb' as [hd' bdy' ex']; simpl in *. subst. + monadInv TBC. monadInv TIC. simpl in *. rewrite H5. rewrite H6. + simpl. repeat eexists. + econstructor. 4: instantiate (3 := false). all:eauto. + unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + assert (f = f0) by congruence. subst f0. econstructor; eauto. + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. eauto. + eapply agree_exten; eauto. intros. Simpl. + discriminate. +Qed. + +Definition mb_remove_first (bb: MB.bblock) := + {| MB.header := MB.header bb; MB.body := tail (MB.body bb); MB.exit := MB.exit bb |}. + +Lemma exec_straight_body: + forall c c' lc rs1 m1 rs2 m2, + exec_straight tge c rs1 m1 c' rs2 m2 -> + code_to_basics c = Some lc -> + exists l ll, + c = l ++ c' + /\ code_to_basics l = Some ll + /\ exec_body tge ll rs1 m1 = Next rs2 m2. +Proof. + induction c; try (intros; inv H; fail). + intros until m2. intros EXES CTB. inv EXES. + - exists (i1 ::g nil),(i1::nil). repeat (split; simpl; auto). rewrite H6. auto. + - inv CTB. destruct (code_to_basics c); try discriminate. inv H0. + eapply IHc in H7; eauto. destruct H7 as (l' & ll & Hc & CTB & EXECB). subst. + exists (i ::g l'),(i::ll). repeat (split; simpl; auto). + rewrite CTB. auto. + rewrite H1. auto. +Qed. + +Lemma basics_to_code_app: + forall c l x ll, + basics_to_code c = l ++ basics_to_code x -> + code_to_basics l = Some ll -> + c = ll ++ x. +Proof. + intros. apply (f_equal code_to_basics) in H. + erewrite code_to_basics_dist in H; eauto. 2: eapply code_to_basics_id. + rewrite code_to_basics_id in H. inv H. auto. +Qed. + +Lemma basics_to_code_app2: + forall i c l x ll, + (PBasic i) :: basics_to_code c = l ++ basics_to_code x -> + code_to_basics l = Some ll -> + i :: c = ll ++ x. +Proof. + intros until ll. intros. + exploit basics_to_code_app. instantiate (3 := (i::c)). simpl. + all: eauto. +Qed. + +(* Handling the individual instructions of theorem (B) in the above diagram. A bit less cumbersome, but still tough *) +Theorem step_simu_basic: + forall bb bb' s fb sp c ms m rs1 m1 ms' m' bi cs1 tbdy bdy, + MB.header bb = nil -> MB.body bb = bi::(bdy) -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + bb' = {| MB.header := nil; MB.body := bdy; MB.exit := MB.exit bb |} -> + basic_step ge s fb sp ms m bi ms' m' -> + pstate cs1 = (State rs1 m1) -> pbody1 cs1 = tbdy -> + match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> + (exists rs2 m2 l cs2 tbdy', + cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := tbdy'; pbody2 := pbody2 cs1; + pctl := pctl cs1; ep := fp_is_parent (ep cs1) bi; rem := rem cs1; cur := cur cs1 |} + /\ tbdy = l ++ tbdy' + /\ exec_body tge l rs1 m1 = Next rs2 m2 + /\ match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2). +Proof. + intros until bdy. intros Hheader Hbody Hnobuiltin (* Hnotempty *) Hbb' BSTEP Hpstate Hpbody1 MCS. inv MCS. + simpl in *. inv Hpstate. + rewrite Hbody in TBC. monadInv TBC. + inv BSTEP. + + - (* MBgetstack *) + simpl in EQ0. + unfold Mach.load_stack in H. + exploit Mem.loadv_extends; eauto. intros [v' [A B]]. + rewrite (sp_val _ _ _ AG) in A. + exploit loadind_correct; eauto with asmgen. + intros (rs2 & EXECS & Hrs'1 & Hrs'2). + eapply exec_straight_body in EXECS. + 2: eapply code_to_basics_id; eauto. + destruct EXECS as (l & Hlbi & BTC & CTB & EXECB). + exists rs2, m1, Hlbi. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. } + subst. simpl in Hheadereq. + + eapply match_codestate_intro; eauto. + { simpl. simpl in EQ. rewrite <- Hheadereq in EQ. assumption. } + eapply agree_set_mreg; eauto with asmgen. + intro Hep. simpl in Hep. + destruct (andb_prop _ _ Hep). clear Hep. + rewrite <- Hheadereq in DXP. subst. rewrite <- DXP. rewrite Hrs'2. reflexivity. + discriminate. apply preg_of_not_FP; assumption. reflexivity. + + - (* MBsetstack *) + simpl in EQ0. + unfold Mach.store_stack in H. + assert (Val.lessdef (ms src) (rs1 (preg_of src))). { eapply preg_val; eauto. } + exploit Mem.storev_extends; eauto. intros [m2' [A B]]. + exploit storeind_correct; eauto with asmgen. + rewrite (sp_val _ _ _ AG) in A. eauto. intros [rs' [P Q]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs', m2', ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. + + eapply agree_undef_regs; eauto with asmgen. + simpl; intros. rewrite Q; auto with asmgen. rewrite Hheader in DXP. auto. + - (* MBgetparam *) + simpl in EQ0. + + assert (f0 = f) by congruence; subst f0. + unfold Mach.load_stack in *. + exploit Mem.loadv_extends. eauto. eexact H0. auto. + intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'. + exploit Mem.loadv_extends. eauto. eexact H1. auto. + intros [v' [C D]]. + + monadInv EQ0. rewrite Hheader. rewrite Hheader in DXP. + destruct ep0 eqn:EPeq. + + (* RTMP contains parent *) + + exploit loadind_correct. eexact EQ1. + instantiate (2 := rs1). rewrite DXP; eauto. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & BTC & CTB & EXECB). + exists rs2, m1, ll. eexists. + eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + { eapply basics_to_code_app; eauto. } + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. } + subst. + eapply match_codestate_intro; eauto. + + eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen. + simpl; intros. rewrite R; auto with asmgen. + apply preg_of_not_FP; auto. + + (* RTMP does not contain parent *) + + rewrite chunk_of_Tptr in A. + exploit loadind_ptr_correct. eexact A. intros [rs2 [P [Q R]]]. + exploit loadind_correct. eexact EQ1. instantiate (2 := rs2). rewrite Q. eauto. + intros [rs3 [S [T U]]]. + + exploit exec_straight_trans. + eapply P. + eapply S. + intros EXES. + + eapply exec_straight_body in EXES. + 2: simpl. 2: erewrite code_to_basics_id; eauto. + destruct EXES as (l & ll & BTC & CTB & EXECB). + exists rs3, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app2; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + subst. + eapply match_codestate_intro; eauto. + eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto. + instantiate (1 := rs2#FP <- (rs3#FP)). intros. + rewrite Pregmap.gso; auto with asmgen. + congruence. + intros. unfold Pregmap.set. destruct (PregEq.eq r' FP). congruence. auto with asmgen. + simpl; intros. rewrite U; auto with asmgen. + apply preg_of_not_FP; auto. + - (* MBop *) + simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_operation tge sp op (map ms args) m' = Some v). + rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. + exploit eval_operation_lessdef. + eapply preg_vals; eauto. + 2: eexact H0. + all: eauto. + intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. + apply agree_set_undef_mreg with rs1; auto. + apply Val.lessdef_trans with v'; auto. + simpl; intros. destruct (andb_prop _ _ H1); clear H1. + rewrite R; auto. apply preg_of_not_FP; auto. +Local Transparent destroyed_by_op. + destruct op; simpl; auto; congruence. + - (* MBload *) + simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_addressing tge sp addr (map ms args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit Mem.loadv_extends; eauto. intros [v' [C D]]. + exploit transl_load_correct; eauto. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. + rewrite <- Hheadereq in EQ. assumption. + eapply agree_set_mreg; eauto with asmgen. + intro Hep. simpl in Hep. + destruct (andb_prop _ _ Hep). clear Hep. + subst. rewrite <- DXP. rewrite R; try discriminate. reflexivity. + apply preg_of_not_FP; assumption. reflexivity. + + - (* notrap1 cannot happen *) + simpl in EQ0. unfold transl_load in EQ0. + destruct addr; simpl in H. + all: unfold transl_load_rrrXS, transl_load_rrr, transl_load_rro in EQ0; + monadInv EQ0; unfold transl_memory_access2XS, transl_memory_access2, transl_memory_access in EQ2; + destruct args as [|h0 t0]; try discriminate; + destruct t0 as [|h1 t1]; try discriminate; + destruct t1 as [|h2 t2]; try discriminate. + + - (* MBload notrap2 TODO *) + simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_addressing tge sp addr (map ms args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + + destruct (Mem.loadv chunk m1 a') as [v' | ] eqn:Hload. + { + exploit transl_load_correct; eauto. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + eapply match_codestate_intro; eauto. simpl. rewrite Hheader in *. + simpl in EQ. assumption. + + eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. + + simpl. intro. + rewrite R; try congruence. + apply DXP. + destruct ep0; simpl in *; congruence. + apply preg_of_not_FP. + destruct ep0; simpl in *; congruence. + } + { + exploit transl_load_correct_notrap2; eauto. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. +(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + rewrite <- Hheadereq. *) subst. + eapply match_codestate_intro; eauto. simpl. rewrite Hheader in *. simpl in EQ. assumption. + + eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. + simpl. intro. + rewrite R; try congruence. + apply DXP. + destruct ep0; simpl in *; congruence. + apply preg_of_not_FP. + destruct ep0; simpl in *; congruence. + } + - (* MBstore *) + simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_addressing tge sp addr (map ms args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + assert (Val.lessdef (ms src) (rs1 (preg_of src))). eapply preg_val; eauto. + exploit Mem.storev_extends; eauto. intros [m2' [C D]]. + exploit transl_store_correct; eauto. intros [rs2 [P Q]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m2', ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. + rewrite <- Hheadereq in EQ. assumption. + eapply agree_undef_regs; eauto with asmgen. + intro Hep. simpl in Hep. + subst. rewrite <- DXP. rewrite Q; try discriminate. reflexivity. reflexivity. +Qed. + +Lemma exec_body_trans: + forall l l' rs0 m0 rs1 m1 rs2 m2, + exec_body tge l rs0 m0 = Next rs1 m1 -> + exec_body tge l' rs1 m1 = Next rs2 m2 -> + exec_body tge (l++l') rs0 m0 = Next rs2 m2. +Proof. + induction l. + - simpl. congruence. + - intros until m2. intros EXEB1 EXEB2. + inv EXEB1. destruct (exec_basic_instr _) eqn:EBI; try discriminate. + simpl. rewrite EBI. eapply IHl; eauto. +Qed. + +Definition mb_remove_header bb := {| MB.header := nil; MB.body := MB.body bb; MB.exit := MB.exit bb |}. + +Program Definition remove_header tbb := {| header := nil; body := body tbb; exit := exit tbb |}. +Next Obligation. + destruct tbb. simpl. auto. +Qed. + +Inductive exec_header: codestate -> codestate -> Prop := + | exec_header_cons: forall cs1, + exec_header cs1 {| pstate := pstate cs1; pheader := nil; pbody1 := pbody1 cs1; pbody2 := pbody2 cs1; + pctl := pctl cs1; ep := (if pheader cs1 then ep cs1 else false); rem := rem cs1; + cur := cur cs1 |}. + +(* Theorem (A) in the diagram, the easiest of all *) +Theorem step_simu_header: + forall bb s fb sp c ms m rs1 m1 cs1, + pstate cs1 = (State rs1 m1) -> + match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> + (exists cs1', + exec_header cs1 cs1' + /\ match_codestate fb (MB.State s fb sp (mb_remove_header bb::c) ms m) cs1'). +Proof. + intros until cs1. intros Hpstate MCS. + eexists. split; eauto. + econstructor; eauto. + inv MCS. simpl in *. inv Hpstate. + econstructor; eauto. +Qed. + +Lemma step_matchasm_header: + forall fb cs1 cs1' s1, + match_asmstate fb cs1 s1 -> + exec_header cs1 cs1' -> + match_asmstate fb cs1' s1. +Proof. + intros until s1. intros MAS EXH. + inv MAS. inv EXH. + simpl. econstructor; eauto. +Qed. + +(* Theorem (B) in the diagram, using step_simu_basic + induction on the Machblock body *) +Theorem step_simu_body: + forall bb s fb sp c ms m rs1 m1 ms' cs1 m', + MB.header bb = nil -> + (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + body_step ge s fb sp (MB.body bb) ms m ms' m' -> + pstate cs1 = (State rs1 m1) -> + match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> + (exists rs2 m2 cs2 ep, + cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := nil; pbody2 := pbody2 cs1; + pctl := pctl cs1; ep := ep; rem := rem cs1; cur := cur cs1 |} + /\ exec_body tge (pbody1 cs1) rs1 m1 = Next rs2 m2 + /\ match_codestate fb (MB.State s fb sp ({| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |}::c) ms' m') cs2). +Proof. + intros bb. destruct bb as [hd bdy ex]; simpl; auto. induction bdy as [|bi bdy]. + - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. + inv BSTEP. + exists rs1, m1, cs1, (ep cs1). + inv MCS. inv Hpstate. simpl in *. monadInv TBC. repeat (split; simpl; auto). + econstructor; eauto. + - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. inv BSTEP. + rename ms' into ms''. rename m' into m''. rename rs' into ms'. rename m'0 into m'. + exploit (step_simu_basic); eauto. simpl. eauto. simpl; auto. simpl; auto. + intros (rs2 & m2 & l & cs2 & tbdy' & Hcs2 & Happ & EXEB & MCS'). + simpl in *. + exploit IHbdy. auto. 2: eapply H6. 3: eapply MCS'. all: eauto. subst; eauto. simpl; auto. + intros (rs3 & m3 & cs3 & ep & Hcs3 & EXEB' & MCS''). + exists rs3, m3, cs3, ep. + repeat (split; simpl; auto). subst. simpl in *. auto. + rewrite Happ. eapply exec_body_trans; eauto. rewrite Hcs2 in EXEB'; simpl in EXEB'. auto. +Qed. + +Lemma exec_body_control: + forall b rs1 m1 rs2 m2 rs3 m3 fn, + exec_body tge (body b) rs1 m1 = Next rs2 m2 -> + exec_control_rel tge fn (exit b) b rs2 m2 rs3 m3 -> + exec_bblock_rel tge fn b rs1 m1 rs3 m3. +Proof. + intros until fn. intros EXEB EXECTL. + econstructor; eauto. inv EXECTL. + unfold exec_bblock. rewrite EXEB. auto. +Qed. + +Definition mbsize (bb: MB.bblock) := (length (MB.body bb) + length_opt (MB.exit bb))%nat. + +Lemma mbsize_eqz: + forall bb, mbsize bb = 0%nat -> MB.body bb = nil /\ MB.exit bb = None. +Proof. + intros. destruct bb as [hd bdy ex]; simpl in *. unfold mbsize in H. + remember (length _) as a. remember (length_opt _) as b. + assert (a = 0%nat) by omega. assert (b = 0%nat) by omega. subst. clear H. + inv H0. inv H1. destruct bdy; destruct ex; auto. + all: try discriminate. +Qed. + +Lemma mbsize_neqz: + forall bb, mbsize bb <> 0%nat -> (MB.body bb <> nil \/ MB.exit bb <> None). +Proof. + intros. destruct bb as [hd bdy ex]; simpl in *. + destruct bdy; destruct ex; try (right; discriminate); try (left; discriminate). + contradict H. unfold mbsize. simpl. auto. +Qed. + +(* Bringing theorems (A), (B) and (C) together, for the case of the absence of builtin instruction *) +(* This more general form is easier to prove, but the actual theorem is step_simulation_bblock further below *) +Lemma step_simulation_bblock': + forall sf f sp bb bb' bb'' rs m rs' m' s'' c S1, + bb' = mb_remove_header bb -> + body_step ge sf f sp (Machblock.body bb') rs m rs' m' -> + bb'' = mb_remove_body bb' -> + (forall ef args res, MB.exit bb'' <> Some (MBbuiltin ef args res)) -> + exit_step return_address_offset ge (Machblock.exit bb'') (Machblock.State sf f sp (bb'' :: c) rs' m') E0 s'' -> + match_states (Machblock.State sf f sp (bb :: c) rs m) S1 -> + exists S2 : state, plus step tge S1 E0 S2 /\ match_states s'' S2. +Proof. + intros until S1. intros Hbb' BSTEP Hbb'' Hbuiltin ESTEP MS. + destruct (mbsize bb) eqn:SIZE. + - apply mbsize_eqz in SIZE. destruct SIZE as (Hbody & Hexit). + destruct bb as [hd bdy ex]; simpl in *; subst. + inv MS. inv AT. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc. + monadInv H2. simpl in *. inv ESTEP. inv BSTEP. + eexists. split. eapply plus_one. + exploit functions_translated; eauto. intros (tf0 & FIND' & TRANSF'). monadInv TRANSF'. + assert (x = tf) by congruence. subst x. + eapply exec_step_internal; eauto. eapply find_bblock_tail; eauto. + unfold exec_bblock. simpl. eauto. + econstructor. eauto. eauto. eauto. + unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite <- H. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + econstructor; eauto. + generalize (code_tail_next_int _ _ _ _ NOOV H3). intro CT1. eauto. + eapply agree_exten; eauto. intros. Simpl. + intros. discriminate. + - subst. exploit mbsize_neqz. { instantiate (1 := bb). rewrite SIZE. discriminate. } + intros Hnotempty. + + (* initial setting *) + exploit match_state_codestate. + 2: eapply Hnotempty. + all: eauto. + intros (cs1 & fb & f0 & tbb & tc & ep & MCS & MAS & FIND & TLBS & Hbody & Hexit & Hcur & Hrem & Hpstate). + + (* step_simu_header part *) + assert (exists rs1 m1, pstate cs1 = State rs1 m1). { inv MAS. simpl. eauto. } + destruct H as (rs1 & m1 & Hpstate2). subst. + assert (f = fb). { inv MCS. auto. } subst fb. + exploit step_simu_header. + 2: eapply MCS. + all: eauto. + intros (cs1' & EXEH & MCS2). + + (* step_simu_body part *) + assert (Hpstate': pstate cs1' = pstate cs1). { inv EXEH; auto. } + exploit step_simu_body. + 3: eapply BSTEP. + 4: eapply MCS2. + all: eauto. rewrite Hpstate'. eauto. + intros (rs2 & m2 & cs2 & ep' & Hcs2 & EXEB & MCS'). + + (* step_simu_control part *) + assert (exists tf, Genv.find_funct_ptr tge f = Some (Internal tf)). + { exploit functions_translated; eauto. intros (tf & FIND' & TRANSF'). monadInv TRANSF'. eauto. } + destruct H as (tf & FIND'). + assert (exists tex, pbody2 cs1 = extract_basic tex /\ pctl cs1 = extract_ctl tex). + { inv MAS. simpl in *. eauto. } + destruct H as (tex & Hpbody2 & Hpctl). + inv EXEH. simpl in *. + subst. exploit step_simu_control. + 9: eapply MCS'. all: simpl. + 10: eapply ESTEP. + all: simpl; eauto. + rewrite Hpbody2. rewrite Hpctl. + { inv MAS; simpl in *. inv Hpstate2. eapply match_asmstate_some; eauto. + erewrite exec_body_pc; eauto. } + intros (rs3 & m3 & rs4 & m4 & EXEB' & EXECTL' & MS'). + + (* bringing the pieces together *) + exploit exec_body_trans. + eapply EXEB. + eauto. + intros EXEB2. + exploit exec_body_control; eauto. + rewrite <- Hpbody2 in EXEB2. rewrite <- Hbody in EXEB2. eauto. + rewrite Hexit. rewrite Hpctl. eauto. + intros EXECB. inv EXECB. + exists (State rs4 m4). + split; auto. eapply plus_one. rewrite Hpstate2. + assert (exists ofs, rs1 PC = Vptr f ofs). + { rewrite Hpstate2 in MAS. inv MAS. simpl in *. eauto. } + destruct H0 as (ofs & Hrs1pc). + eapply exec_step_internal; eauto. + + (* proving the initial find_bblock *) + rewrite Hpstate2 in MAS. inv MAS. simpl in *. + assert (f1 = f0) by congruence. subst f0. + rewrite PCeq in Hrs1pc. inv Hrs1pc. + exploit functions_translated; eauto. intros (tf1 & FIND'' & TRANS''). rewrite FIND' in FIND''. + inv FIND''. monadInv TRANS''. rewrite TRANSF0 in EQ. inv EQ. + eapply find_bblock_tail; eauto. +Qed. + +Theorem step_simulation_bblock: + forall sf f sp bb ms m ms' m' S2 c, + body_step ge sf f sp (Machblock.body bb) ms m ms' m' -> + (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + exit_step return_address_offset ge (Machblock.exit bb) (Machblock.State sf f sp (bb :: c) ms' m') E0 S2 -> + forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' -> + exists S2' : state, plus step tge S1' E0 S2' /\ match_states S2 S2'. +Proof. + intros until c. intros BSTEP Hbuiltin ESTEP S1' MS. + eapply step_simulation_bblock'; eauto. + all: destruct bb as [hd bdy ex]; simpl in *; eauto. + inv ESTEP. + - econstructor. inv H; try (econstructor; eauto; fail). + - econstructor. +Qed. + +(** Dealing now with the builtin case *) + +Definition split (c: MB.code) := + match c with + | nil => nil + | bb::c => {| MB.header := MB.header bb; MB.body := MB.body bb; MB.exit := None |} + :: {| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |} :: c + end. + +Lemma cons_ok_eq3 {A: Type} : + forall (x:A) y z x' y' z', + x = x' -> y = y' -> z = z' -> + OK (x::y::z) = OK (x'::y'::z'). +Proof. + intros. subst. auto. +Qed. + +Lemma transl_blocks_split_builtin: + forall bb c ep f ef args res, + MB.exit bb = Some (MBbuiltin ef args res) -> MB.body bb <> nil -> + transl_blocks f (split (bb::c)) ep = transl_blocks f (bb::c) ep. +Proof. + intros until res. intros Hexit Hbody. simpl split. + unfold transl_blocks. fold transl_blocks. unfold transl_block. + simpl. remember (transl_basic_code _ _ _) as tbc. remember (transl_instr_control _ _) as tbi. + remember (transl_blocks _ _ _) as tlbs. + destruct tbc; destruct tbi; destruct tlbs. + all: try simpl; auto. + - simpl. rewrite Hexit in Heqtbi. simpl in Heqtbi. monadInv Heqtbi. simpl. + unfold gen_bblocks. simpl. destruct l. + + exploit transl_basic_code_nonil; eauto. intro. destruct H. + + simpl. rewrite app_nil_r. apply cons_ok_eq3. all: try eapply bblock_equality. all: simpl; auto. +Qed. + +Lemma transl_code_at_pc_split_builtin: + forall rs f f0 bb c ep tf tc ef args res, + MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) -> + transl_code_at_pc ge (rs PC) f f0 (bb :: c) ep tf tc -> + transl_code_at_pc ge (rs PC) f f0 (split (bb :: c)) ep tf tc. +Proof. + intros until res. intros Hbody Hexit AT. inv AT. + econstructor; eauto. erewrite transl_blocks_split_builtin; eauto. +Qed. + +Theorem match_states_split_builtin: + forall sf f sp bb c rs m ef args res S1, + MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) -> + match_states (Machblock.State sf f sp (bb :: c) rs m) S1 -> + match_states (Machblock.State sf f sp (split (bb::c)) rs m) S1. +Proof. + intros until S1. intros Hbody Hexit MS. + inv MS. + econstructor; eauto. + eapply transl_code_at_pc_split_builtin; eauto. +Qed. + +Theorem step_simulation_builtin: + forall ef args res bb sf f sp c ms m t S2, + MB.body bb = nil -> MB.exit bb = Some (MBbuiltin ef args res) -> + exit_step return_address_offset ge (MB.exit bb) (Machblock.State sf f sp (bb :: c) ms m) t S2 -> + forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' -> + exists S2' : state, plus step tge S1' t S2' /\ match_states S2 S2'. +Proof. + intros until S2. intros Hbody Hexit ESTEP S1' MS. + inv MS. inv AT. monadInv H2. monadInv EQ. + rewrite Hbody in EQ0. monadInv EQ0. + rewrite Hexit in EQ. monadInv EQ. + rewrite Hexit in ESTEP. inv ESTEP. inv H4. + + exploit functions_transl; eauto. intro FN. + generalize (transf_function_no_overflow _ _ H1); intro NOOV. + exploit builtin_args_match; eauto. intros [vargs' [P Q]]. + exploit external_call_mem_extends; eauto. + intros [vres' [m2' [A [B [C D]]]]]. + econstructor; split. apply plus_one. + simpl in H3. + eapply exec_step_builtin. eauto. eauto. + eapply find_bblock_tail; eauto. + simpl. eauto. + erewrite <- sp_val by eauto. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + eauto. + econstructor; eauto. + instantiate (2 := tf); instantiate (1 := x0). + unfold nextblock, incrPC. rewrite Pregmap.gss. + rewrite set_res_other. rewrite undef_regs_other_2. rewrite Pregmap.gso by congruence. + rewrite <- H. simpl. econstructor; eauto. + eapply code_tail_next_int; eauto. + rewrite preg_notin_charact. intros. auto with asmgen. + auto with asmgen. + apply agree_nextblock. eapply agree_set_res; auto. + eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto. + apply Pregmap.gso; auto with asmgen. + congruence. +Qed. + +Lemma next_sep: + forall rs m rs' m', rs = rs' -> m = m' -> Next rs m = Next rs' m'. +Proof. + congruence. +Qed. + +(* Measure to prove finite stuttering, see the other backends *) +Definition measure (s: MB.state) : nat := + match s with + | MB.State _ _ _ _ _ _ => 0%nat + | MB.Callstate _ _ _ _ => 0%nat + | MB.Returnstate _ _ _ => 1%nat + end. + +(* The actual MB.step/AB.step simulation, using the above theorems, plus extra proofs + for the internal and external function cases *) +Theorem step_simulation: + forall S1 t S2, MB.step return_address_offset ge S1 t S2 -> + forall S1' (MS: match_states S1 S1'), + (exists S2', plus step tge S1' t S2' /\ match_states S2 S2') + \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat. +Proof. + induction 1; intros. + +- (* bblock *) + left. destruct (Machblock.exit bb) eqn:MBE; try destruct c0. + all: try(inversion H0; subst; inv H2; eapply step_simulation_bblock; + try (rewrite MBE; try discriminate); eauto). + + (* MBbuiltin *) + destruct (MB.body bb) eqn:MBB. + * inv H. eapply step_simulation_builtin; eauto. rewrite MBE. eauto. + * eapply match_states_split_builtin in MS; eauto. + 2: rewrite MBB; discriminate. + simpl split in MS. + rewrite <- MBB in H. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb1. + assert (MB.body bb = MB.body bb1). { subst. simpl. auto. } + rewrite H1 in H. subst. + exploit step_simulation_bblock. eapply H. + discriminate. + simpl. constructor. + eauto. + intros (S2' & PLUS1 & MS'). + rewrite MBE in MS'. + assert (exit_step return_address_offset ge (Some (MBbuiltin e l b)) + (MB.State sf f sp ({| MB.header := nil; MB.body := nil; MB.exit := Some (MBbuiltin e l b) |}::c) + rs' m') t s'). + { inv H0. inv H3. econstructor. econstructor; eauto. } + exploit step_simulation_builtin. + 4: eapply MS'. + all: simpl; eauto. + intros (S3' & PLUS'' & MS''). + exists S3'. split; eauto. + eapply plus_trans. eapply PLUS1. eapply PLUS''. eauto. + + inversion H0. subst. eapply step_simulation_bblock; try (rewrite MBE; try discriminate); eauto. + +- (* internal function *) + inv MS. + exploit functions_translated; eauto. intros [tf [A B]]. monadInv B. + generalize EQ; intros EQ'. monadInv EQ'. + destruct (zlt Ptrofs.max_unsigned (size_blocks x0.(fn_blocks))); inversion EQ1. clear EQ1. subst x0. + unfold Mach.store_stack in *. + exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl. + intros [m1' [C D]]. + exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto. + intros [m2' [F G]]. + simpl chunk_of_type in F. + exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto. + intros [m3' [P Q]]. + (* Execution of function prologue *) + monadInv EQ0. + set (tfbody := make_prologue f x0) in *. + set (tf := {| fn_sig := MB.fn_sig f; fn_blocks := tfbody |}) in *. + set (rs2 := rs0#FP <- (parent_sp s) #SP <- sp #RTMP <- Vundef). + exploit (Pget_correct tge GPRA RA nil rs2 m2'); auto. + intros (rs' & U' & V'). + exploit (storeind_ptr_correct tge SP (fn_retaddr_ofs f) GPRA nil rs' m2'). + { rewrite chunk_of_Tptr in P. + assert (rs' GPRA = rs0 RA). { apply V'. } + assert (rs' SP = rs2 SP). { apply V'; discriminate. } + rewrite H4. rewrite H3. + rewrite ATLR. + change (rs2 SP) with sp. eexact P. } + intros (rs3 & U & V). + assert (EXEC_PROLOGUE: exists rs3', + exec_straight_blocks tge tf + tf.(fn_blocks) rs0 m' + x0 rs3' m3' + /\ forall r, r <> PC -> rs3' r = rs3 r). + { eexists. split. + - change (fn_blocks tf) with tfbody; unfold tfbody. + econstructor; eauto. unfold exec_bblock. simpl exec_body. + rewrite C. fold sp. rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. simpl in F. rewrite F. + Simpl. unfold parexec_store_offset. rewrite Ptrofs.of_int64_to_int64. unfold eval_offset. + rewrite chunk_of_Tptr in P. Simpl. rewrite ATLR. unfold Mptr in P. assert (Archi.ptr64 = true) by auto. 2: auto. rewrite H3 in P. rewrite P. + simpl. apply next_sep; eauto. reflexivity. + - intros. destruct V' as (V'' & V'). destruct r. + + Simpl. + destruct (gpreg_eq g0 GPR16). { subst. Simpl. rewrite V; try discriminate. rewrite V''. subst rs2. Simpl. } + destruct (gpreg_eq g0 GPR32). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } + destruct (gpreg_eq g0 GPR12). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } + destruct (gpreg_eq g0 GPR17). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } + Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. { destruct g0; try discriminate. contradiction. } + + Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. + + contradiction. + } destruct EXEC_PROLOGUE as (rs3' & EXEC_PROLOGUE & Heqrs3'). + exploit exec_straight_steps_2; eauto using functions_transl. + simpl fn_blocks. simpl fn_blocks in g. omega. constructor. + intros (ofs' & X & Y). + left; exists (State rs3' m3'); split. + eapply exec_straight_steps_1; eauto. + simpl fn_blocks. simpl fn_blocks in g. omega. + constructor. + econstructor; eauto. + rewrite X; econstructor; eauto. + apply agree_exten with rs2; eauto with asmgen. + unfold rs2. + apply agree_set_other; auto with asmgen. + apply agree_change_sp with (parent_sp s). + apply agree_undef_regs with rs0. auto. +Local Transparent destroyed_at_function_entry. + simpl; intros; Simpl. + unfold sp; congruence. + + intros. + assert (r <> RTMP). { contradict H3; rewrite H3; unfold data_preg; auto. } + rewrite Heqrs3'. Simpl. rewrite V. inversion V'. rewrite H6. auto. + assert (r <> GPRA). { contradict H3; rewrite H3; unfold data_preg; auto. } + assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } + contradict H3; rewrite H3; unfold data_preg; auto. + contradict H3; rewrite H3; unfold data_preg; auto. + contradict H3; rewrite H3; unfold data_preg; auto. + contradict H3; rewrite H3; unfold data_preg; auto. + intros. rewrite Heqrs3'. rewrite V by auto with asmgen. + assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } + rewrite H4 by auto with asmgen. reflexivity. discriminate. + +- (* external function *) + inv MS. + exploit functions_translated; eauto. + intros [tf [A B]]. simpl in B. inv B. + exploit extcall_arguments_match; eauto. + intros [args' [C D]]. + exploit external_call_mem_extends; eauto. + intros [res' [m2' [P [Q [R S]]]]]. + left; econstructor; split. + apply plus_one. eapply exec_step_external; eauto. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + econstructor; eauto. + unfold loc_external_result. + apply agree_set_other; auto. + apply agree_set_pair; auto. + apply agree_undef_caller_save_regs; auto. + +- (* return *) + inv MS. + inv STACKS. simpl in *. + right. split. omega. split. auto. + rewrite <- ATPC in H5. + econstructor; eauto. congruence. +Qed. + +Lemma transf_initial_states: + forall st1, MB.initial_state prog st1 -> + exists st2, AB.initial_state tprog st2 /\ match_states st1 st2. +Proof. + intros. inversion H. unfold ge0 in *. + econstructor; split. + econstructor. + eapply (Genv.init_mem_transf_partial TRANSF); eauto. + replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero) + with (Vptr fb Ptrofs.zero). + econstructor; eauto. + constructor. + apply Mem.extends_refl. + split. auto. simpl. unfold Vnullptr; destruct Archi.ptr64; congruence. + intros. rewrite Mach.Regmap.gi. auto. + unfold Genv.symbol_address. + rewrite (match_program_main TRANSF). + rewrite symbols_preserved. + unfold ge; rewrite H1. auto. +Qed. + +Lemma transf_final_states: + forall st1 st2 r, + match_states st1 st2 -> MB.final_state st1 r -> AB.final_state st2 r. +Proof. + intros. inv H0. inv H. constructor. assumption. + compute in H1. inv H1. + generalize (preg_val _ _ _ R0 AG). rewrite H2. intros LD; inv LD. auto. +Qed. + +Definition return_address_offset : Machblock.function -> Machblock.code -> ptrofs -> Prop := + Asmblockgenproof0.return_address_offset. + +Theorem transf_program_correct: + forward_simulation (MB.semantics return_address_offset prog) (Asmblock.semantics tprog). +Proof. + eapply forward_simulation_star with (measure := measure). + - apply senv_preserved. + - eexact transf_initial_states. + - eexact transf_final_states. + - exact step_simulation. +Qed. + +End PRESERVATION. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 3c1162bd..00df01e3 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -15,12 +15,16 @@ (* *) (* *********************************************************************) +(** * Proof of correctness for individual instructions *) + Require Import Coqlib Errors Maps. Require Import AST Integers Floats Values Memory Globalenvs. Require Import Op Locations Machblock Conventions. -Require Import Asmblock Asmblockgen Asmblockgenproof0. +Require Import Asmblock Asmblockgen Asmblockgenproof0 Asmblockprops. Require Import Chunks. +Import PArithCoercions. + (** Decomposition of integer constants. *) Lemma make_immed32_sound: @@ -86,31 +90,6 @@ Section CONSTRUCTORS. Variable ge: genv. Variable fn: function. -(* -(** 32-bit integer constants and arithmetic *) -(* -Lemma load_hilo32_correct: - forall rd hi lo k rs m, - exists rs', - exec_straight ge fn (load_hilo32 rd hi lo k) rs m k rs' m - /\ rs'#rd = Vint (Int.add (Int.shl hi (Int.repr 12)) lo) - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - unfold load_hilo32; intros. - predSpec Int.eq Int.eq_spec lo Int.zero. -- subst lo. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split. rewrite Int.add_zero. Simpl. - intros; Simpl. -- econstructor; split. - eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - split. Simpl. - intros; Simpl. -Qed. -*) - -*) - Lemma loadimm32_correct: forall rd n k rs m, exists rs', @@ -141,60 +120,6 @@ Proof. intros; Simpl. Qed. -(* -(* -Lemma opimm32_correct: - forall (op: ireg -> ireg0 -> ireg0 -> instruction) - (opi: ireg -> ireg0 -> int -> instruction) - (sem: val -> val -> val) m, - (forall d s1 s2 rs, - exec_instr ge fn (op d s1 s2) rs m = Next (nextinstr (rs#d <- (sem rs##s1 rs##s2))) m) -> - (forall d s n rs, - exec_instr ge fn (opi d s n) rs m = Next (nextinstr (rs#d <- (sem rs##s (Vint n)))) m) -> - forall rd r1 n k rs, - r1 <> RTMP -> - exists rs', - exec_straight ge fn (opimm32 op opi rd r1 n k) rs m k rs' m - /\ rs'#rd = sem rs##r1 (Vint n) - /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. -Proof. - intros. unfold opimm32. generalize (make_immed32_sound n); intros E. - destruct (make_immed32 n). -- subst imm. econstructor; split. - apply exec_straight_one. rewrite H0. simpl; eauto. auto. - split. Simpl. intros; Simpl. -- destruct (load_hilo32_correct RTMP hi lo (op rd r1 RTMP :: k) rs m) - as (rs' & A & B & C). - econstructor; split. - eapply exec_straight_trans. eexact A. apply exec_straight_one. - rewrite H; eauto. auto. - split. Simpl. simpl. rewrite B, C, E. auto. congruence. congruence. - intros; Simpl. -Qed. - -(** 64-bit integer constants and arithmetic *) - -Lemma load_hilo64_correct: - forall rd hi lo k rs m, - exists rs', - exec_straight ge fn (load_hilo64 rd hi lo k) rs m k rs' m - /\ rs'#rd = Vlong (Int64.add (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))) lo) - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - unfold load_hilo64; intros. - predSpec Int64.eq Int64.eq_spec lo Int64.zero. -- subst lo. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split. rewrite Int64.add_zero. Simpl. - intros; Simpl. -- econstructor; split. - eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - split. Simpl. - intros; Simpl. -Qed. -*) -*) - Lemma opimm64_correct: forall (op: arith_name_rrr) (opi: arith_name_rri64) @@ -215,18 +140,6 @@ Proof. - subst imm. econstructor; split. apply exec_straight_one. rewrite H0. simpl; eauto. auto. split. Simpl. intros; Simpl. -(* -- destruct (load_hilo64_correct RTMP hi lo (op rd r1 RTMP :: k) rs m) - as (rs' & A & B & C). - econstructor; split. - eapply exec_straight_trans. eexact A. apply exec_straight_one. - rewrite H; eauto. auto. - split. Simpl. simpl. rewrite B, C, E. auto. congruence. congruence. - intros; Simpl. -- subst imm. econstructor; split. - eapply exec_straight_two. simpl; eauto. rewrite H. simpl; eauto. auto. auto. - split. Simpl. intros; Simpl. -*) Qed. (** Add offset to pointer *) @@ -252,35 +165,6 @@ Proof. rewrite Ptrofs.of_int64_to_int64 by auto. auto. Qed. -(* -(* -Lemma addptrofs_correct_2: - forall rd r1 n k (rs: regset) m b ofs, - r1 <> RTMP -> rs#r1 = Vptr b of -s -> - exists rs', - exec_straight ge fn (addptrofs rd r1 n k) rs m k rs' m - /\ rs'#rd = Vptr b (Ptrofs.add ofs n) - /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. -Proof. - intros. exploit (addptrofs_correct rd r1 n); eauto. intros (rs' & A & B & C). - exists rs'; intuition eauto. - rewrite H0 in B. inv B. auto. -Qed. - -(** Translation of conditional branches *) - -Remark branch_on_RTMP: - forall normal lbl (rs: regset) m b, - rs#RTMP = Val.of_bool (eqb normal b) -> - exec_instr ge fn (if normal then Pbnew RTMP X0 lbl else Pbeqw RTMP X0 lbl) rs m = - eval_branch fn lbl rs m (Some b). -Proof. - intros. destruct normal; simpl; rewrite H; simpl; destruct b; reflexivity. -Qed. -*) -*) - Ltac ArgsInv := repeat (match goal with | [ H: Error _ = OK _ |- _ ] => discriminate @@ -977,7 +861,7 @@ Proof. destruct cmp; discriminate. Qed. -Local Hint Resolve Val_cmpu_bool_correct Val_cmplu_bool_correct. +Local Hint Resolve Val_cmpu_bool_correct Val_cmplu_bool_correct: core. Lemma transl_cbranch_correct_1: forall cond args lbl k c m ms b sp rs m' tbb, @@ -1281,7 +1165,7 @@ Proof. split; intros; Simpl. Qed. -Local Hint Resolve Val_cmpu_correct Val_cmplu_correct. +Local Hint Resolve Val_cmpu_correct Val_cmplu_correct: core. Lemma transl_condimm_int32u_correct: forall cmp rd r1 n k rs m, @@ -1522,99 +1406,6 @@ Proof. exploit transl_cond_nofloat32_correct; eauto. intros (rs' & A & B & C). exists rs'; eauto. Qed. -(* -(* -+ (* cmpf *) - destruct (transl_cond_float c0 rd x x0) as [insn normal] eqn:TR. - fold (Val.cmpf c0 (rs x) (rs x0)). - set (v := Val.cmpf c0 (rs x) (rs x0)). - destruct normal; inv EQ2. -* econstructor; split. - apply exec_straight_one. eapply transl_cond_float_correct with (v := v); eauto. auto. - split; intros; Simpl. -* econstructor; split. - eapply exec_straight_two. - eapply transl_cond_float_correct with (v := Val.notbool v); eauto. - simpl; reflexivity. - auto. auto. - split; intros; Simpl. unfold v, Val.cmpf. destruct (Val.cmpf_bool c0 (rs x) (rs x0)) as [[]|]; auto. -+ (* notcmpf *) - destruct (transl_cond_float c0 rd x x0) as [insn normal] eqn:TR. - rewrite Val.notbool_negb_3. fold (Val.cmpf c0 (rs x) (rs x0)). - set (v := Val.cmpf c0 (rs x) (rs x0)). - destruct normal; inv EQ2. -* econstructor; split. - eapply exec_straight_two. - eapply transl_cond_float_correct with (v := v); eauto. - simpl; reflexivity. - auto. auto. - split; intros; Simpl. unfold v, Val.cmpf. destruct (Val.cmpf_bool c0 (rs x) (rs x0)) as [[]|]; auto. -* econstructor; split. - apply exec_straight_one. eapply transl_cond_float_correct with (v := Val.notbool v); eauto. auto. - split; intros; Simpl. -+ (* cmpfs *) - destruct (transl_cond_single c0 rd x x0) as [insn normal] eqn:TR. - fold (Val.cmpfs c0 (rs x) (rs x0)). - set (v := Val.cmpfs c0 (rs x) (rs x0)). - destruct normal; inv EQ2. -* econstructor; split. - apply exec_straight_one. eapply transl_cond_single_correct with (v := v); eauto. auto. - split; intros; Simpl. -* econstructor; split. - eapply exec_straight_two. - eapply transl_cond_single_correct with (v := Val.notbool v); eauto. - simpl; reflexivity. - auto. auto. - split; intros; Simpl. unfold v, Val.cmpfs. destruct (Val.cmpfs_bool c0 (rs x) (rs x0)) as [[]|]; auto. -+ (* notcmpfs *) - destruct (transl_cond_single c0 rd x x0) as [insn normal] eqn:TR. - rewrite Val.notbool_negb_3. fold (Val.cmpfs c0 (rs x) (rs x0)). - set (v := Val.cmpfs c0 (rs x) (rs x0)). - destruct normal; inv EQ2. -* econstructor; split. - eapply exec_straight_two. - eapply transl_cond_single_correct with (v := v); eauto. - simpl; reflexivity. - auto. auto. - split; intros; Simpl. unfold v, Val.cmpfs. destruct (Val.cmpfs_bool c0 (rs x) (rs x0)) as [[]|]; auto. -* econstructor; split. - apply exec_straight_one. eapply transl_cond_single_correct with (v := Val.notbool v); eauto. auto. - split; intros; Simpl. -*) -*) - -(** Some arithmetic properties. *) - -(* Remark cast32unsigned_from_cast32signed: - forall i, Int64.repr (Int.unsigned i) = Int64.zero_ext 32 (Int64.repr (Int.signed i)). -Proof. - intros. apply Int64.same_bits_eq; intros. - rewrite Int64.bits_zero_ext, !Int64.testbit_repr by tauto. - rewrite Int.bits_signed by tauto. fold (Int.testbit i i0). - change Int.zwordsize with 32. - destruct (zlt i0 32). auto. apply Int.bits_above. auto. -Qed. - -Lemma cast32signed_correct: - forall (d s: ireg) (k: code) (rs: regset) (m: mem), - exists rs': regset, - exec_straight ge (cast32signed d s ::g k) rs m k rs' m - /\ Val.lessdef (Val.longofint (rs s)) (rs' d) - /\ (forall r: preg, r <> PC -> r <> d -> rs' r = rs r). -Proof. - intros. unfold cast32signed. destruct (ireg_eq d s). -- econstructor; split. - + apply exec_straight_one. simpl. eauto with asmgen. - + split. - * rewrite e. Simpl. - * intros. destruct r; Simpl. -- econstructor; split. - + apply exec_straight_one. simpl. eauto with asmgen. - + split. - * Simpl. - * intros. destruct r; Simpl. -Qed. *) - (* Translation of arithmetic operations *) Ltac SimplEval H := @@ -1649,6 +1440,51 @@ Proof. destruct (Z.eq_dec _ _); destruct (Z.eq_dec _ _); congruence. Qed. +Lemma select_same_lessdef: + forall ty c v, + Val.lessdef (Val.select c v v ty) v. +Proof. + intros. + unfold Val.select. + destruct c; try econstructor. + replace (if b then v else v) with v by (destruct b ; trivial). + destruct v; destruct ty; simpl; econstructor. +Qed. + +Lemma if_neg : forall X, + forall a, + forall b c : X, + (if (negb a) then b else c) = (if a then c else b). +Proof. + destruct a; reflexivity. +Qed. + +Lemma int_ltu_to_neq: + forall x, + Int.ltu Int.zero x = negb (Int.eq x Int.zero). +Proof. + intros. + unfold Int.ltu, Int.eq. + change (Int.unsigned Int.zero) with 0. + pose proof (Int.unsigned_range x) as RANGE. + unfold zlt, zeq. + destruct (Z_lt_dec _ _); destruct (Z.eq_dec _ _); trivial; omega. +Qed. + +Lemma int64_ltu_to_neq: + forall x, + Int64.ltu Int64.zero x = negb (Int64.eq x Int64.zero). +Proof. + intros. + unfold Int64.ltu, Int64.eq. + change (Int64.unsigned Int64.zero) with 0. + pose proof (Int64.unsigned_range x) as RANGE. + unfold zlt, zeq. + destruct (Z_lt_dec _ _); destruct (Z.eq_dec _ _); trivial; omega. +Qed. + +Ltac splitall := repeat match goal with |- _ /\ _ => split end. + Lemma transl_op_correct: forall op args res k (rs: regset) m v c, transl_op op args res k = OK c -> @@ -1683,21 +1519,21 @@ Opaque Int.eq. - (* Ocast8signed *) econstructor; split. eapply exec_straight_two. simpl;eauto. simpl;eauto. - split; intros; simpl; Simpl. + repeat split; intros; simpl; Simpl. assert (A: Int.ltu (Int.repr 24) Int.iwordsize = true) by auto. destruct (rs x0); auto; simpl. rewrite A; simpl. Simpl. unfold Val.shr. rewrite A. apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. - (* Ocast16signed *) econstructor; split. eapply exec_straight_two. simpl;eauto. simpl;eauto. - split; intros; Simpl. + repeat split; intros; Simpl. assert (A: Int.ltu (Int.repr 16) Int.iwordsize = true) by auto. destruct (rs x0); auto; simpl. rewrite A; simpl. Simpl. unfold Val.shr. rewrite A. apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. - (* Oshrximm *) econstructor; split. + apply exec_straight_one. simpl. eauto. - + split. + + repeat split. * rewrite Pregmap.gss. subst v. destruct (rs x0); simpl; trivial. @@ -1708,7 +1544,7 @@ Opaque Int.eq. - (* Oshrxlimm *) econstructor; split. + apply exec_straight_one. simpl. eauto. - + split. + + repeat split. * rewrite Pregmap.gss. subst v. destruct (rs x0); simpl; trivial. @@ -1716,253 +1552,95 @@ Opaque Int.eq. destruct (Int.ltu _ _); simpl; trivial. * intros. rewrite Pregmap.gso; trivial. + - (* Ocmp *) exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). - exists rs'; split. eexact A. eauto with asmgen. -- (* Oselect *) - destruct cond in *; simpl in *; try congruence; - try monadInv EQ3; - try (injection EQ3; clear EQ3; intro Hrew; rewrite <- Hrew in * ; clear Hrew); - econstructor; split; - try ( eapply exec_straight_one; simpl; reflexivity ). - (* Cmp *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl; - destruct (Val.cmp_bool _ _); simpl; try constructor; - destruct b; simpl; rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - (* Cmpu *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl in *; inv EQ2; simpl. - ** assert (Hcmpuabs := (Val_cmpu_bool_correct m Ceq (rs x1) (Vint Int.zero))). - destruct (Val.cmpu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpuabs true) | rewrite (Hcmpuabs false)]; trivial; - rewrite Pregmap.gss; constructor. - ** assert (Hcmpuabs := (Val_cmpu_bool_correct m Cne (rs x1) (Vint Int.zero))). - destruct (Val.cmpu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpuabs true) | rewrite (Hcmpuabs false)]; trivial; - rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - - (* Cmpl *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl; - destruct (Val.cmpl_bool _ _); simpl; try constructor; - destruct b; simpl; rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - - (* Cmplu *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl in *; inv EQ2; simpl. - ** assert (Hcmpluabs := (Val_cmplu_bool_correct m Ceq (rs x1) (Vlong Int64.zero))). - destruct (Val.cmplu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpluabs true) | rewrite (Hcmpluabs false)]; trivial; - rewrite Pregmap.gss; constructor. - ** assert (Hcmpluabs := (Val_cmplu_bool_correct m Cne (rs x1) (Vlong Int64.zero))). - destruct (Val.cmplu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpluabs true) | rewrite (Hcmpluabs false)]; trivial; - rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - -- (* Oselectl *) - destruct cond in *; simpl in *; try congruence; - try monadInv EQ3; - try (injection EQ3; clear EQ3; intro Hrew; rewrite <- Hrew in * ; clear Hrew); - econstructor; split; - try ( eapply exec_straight_one; simpl; reflexivity ). - (* Cmp *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl; - destruct (Val.cmp_bool _ _); simpl; try constructor; - destruct b; simpl; rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - (* Cmpu *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl in *; inv EQ2; simpl. - ** assert (Hcmpuabs := (Val_cmpu_bool_correct m Ceq (rs x1) (Vint Int.zero))). - destruct (Val.cmpu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpuabs true) | rewrite (Hcmpuabs false)]; trivial; - rewrite Pregmap.gss; constructor. - ** assert (Hcmpuabs := (Val_cmpu_bool_correct m Cne (rs x1) (Vint Int.zero))). - destruct (Val.cmpu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpuabs true) | rewrite (Hcmpuabs false)]; trivial; - rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - - (* Cmpl *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl; - destruct (Val.cmpl_bool _ _); simpl; try constructor; - destruct b; simpl; rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - - (* Cmplu *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl in *; inv EQ2; simpl. - ** assert (Hcmpluabs := (Val_cmplu_bool_correct m Ceq (rs x1) (Vlong Int64.zero))). - destruct (Val.cmplu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpluabs true) | rewrite (Hcmpluabs false)]; trivial; - rewrite Pregmap.gss; constructor. - ** assert (Hcmpluabs := (Val_cmplu_bool_correct m Cne (rs x1) (Vlong Int64.zero))). - destruct (Val.cmplu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpluabs true) | rewrite (Hcmpluabs false)]; trivial; - rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - -- (* Oselectf *) - destruct cond in *; simpl in *; try congruence; - try monadInv EQ3; - try (injection EQ3; clear EQ3; intro Hrew; rewrite <- Hrew in * ; clear Hrew); - econstructor; split; - try ( eapply exec_straight_one; simpl; reflexivity ). - (* Cmp *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl; - destruct (Val.cmp_bool _ _); simpl; try constructor; - destruct b; simpl; rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - (* Cmpu *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl in *; inv EQ2; simpl. - ** assert (Hcmpuabs := (Val_cmpu_bool_correct m Ceq (rs x1) (Vint Int.zero))). - destruct (Val.cmpu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpuabs true) | rewrite (Hcmpuabs false)]; trivial; - rewrite Pregmap.gss; constructor. - ** assert (Hcmpuabs := (Val_cmpu_bool_correct m Cne (rs x1) (Vint Int.zero))). - destruct (Val.cmpu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpuabs true) | rewrite (Hcmpuabs false)]; trivial; - rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - - (* Cmpl *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl; - destruct (Val.cmpl_bool _ _); simpl; try constructor; - destruct b; simpl; rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - - (* Cmplu *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl in *; inv EQ2; simpl. - ** assert (Hcmpluabs := (Val_cmplu_bool_correct m Ceq (rs x1) (Vlong Int64.zero))). - destruct (Val.cmplu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpluabs true) | rewrite (Hcmpluabs false)]; trivial; - rewrite Pregmap.gss; constructor. - ** assert (Hcmpluabs := (Val_cmplu_bool_correct m Cne (rs x1) (Vlong Int64.zero))). - destruct (Val.cmplu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpluabs true) | rewrite (Hcmpluabs false)]; trivial; - rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - - -- (* Oselectfs *) - destruct cond in *; simpl in *; try congruence; - try monadInv EQ3; - try (injection EQ3; clear EQ3; intro Hrew; rewrite <- Hrew in * ; clear Hrew); - econstructor; split; - try ( eapply exec_straight_one; simpl; reflexivity ). - (* Cmp *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl; - destruct (Val.cmp_bool _ _); simpl; try constructor; - destruct b; simpl; rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - (* Cmpu *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl in *; inv EQ2; simpl. - ** assert (Hcmpuabs := (Val_cmpu_bool_correct m Ceq (rs x1) (Vint Int.zero))). - destruct (Val.cmpu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpuabs true) | rewrite (Hcmpuabs false)]; trivial; - rewrite Pregmap.gss; constructor. - ** assert (Hcmpuabs := (Val_cmpu_bool_correct m Cne (rs x1) (Vint Int.zero))). - destruct (Val.cmpu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpuabs true) | rewrite (Hcmpuabs false)]; trivial; - rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - - (* Cmpl *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl; - destruct (Val.cmpl_bool _ _); simpl; try constructor; - destruct b; simpl; rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - - (* Cmplu *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl in *; inv EQ2; simpl. - ** assert (Hcmpluabs := (Val_cmplu_bool_correct m Ceq (rs x1) (Vlong Int64.zero))). - destruct (Val.cmplu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpluabs true) | rewrite (Hcmpluabs false)]; trivial; - rewrite Pregmap.gss; constructor. - ** assert (Hcmpluabs := (Val_cmplu_bool_correct m Cne (rs x1) (Vlong Int64.zero))). - destruct (Val.cmplu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpluabs true) | rewrite (Hcmpluabs false)]; trivial; - rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. + exists rs'; repeat split; eauto with asmgen. + +- (* Osel *) + unfold conditional_move in *. + destruct (ireg_eq _ _). + { + subst x. inv EQ2. + econstructor; split. + { + apply exec_straight_one. + simpl. reflexivity. + } + split. + { apply select_same_lessdef. } + intros; trivial. + } + + destruct c0; simpl in *. + + all: destruct c. + all: simpl in *. + all: inv EQ2. + all: econstructor; splitall. + all: try apply exec_straight_one. + all: intros; simpl; trivial. + all: unfold Val.select, cmove, cmoveu; simpl. + all: destruct (rs x1); simpl; trivial. + all: try rewrite int_ltu_to_neq. + all: try rewrite int64_ltu_to_neq. + all: try change (Int64.eq Int64.zero Int64.zero) with true. + all: try destruct Archi.ptr64. + all: try rewrite Pregmap.gss. + all: repeat rewrite if_neg. + all: simpl. + all: try destruct (_ || _). + all: try apply Val.lessdef_normalize. + all: trivial. (* no more lessdef *) + all: apply Pregmap.gso; congruence. + +- (* Oselimm *) + unfold conditional_move_imm32 in *. + destruct c0; simpl in *. + + all: destruct c. + all: simpl in *. + all: inv EQ0. + all: econstructor; splitall. + all: try apply exec_straight_one. + all: intros; simpl; trivial. + all: unfold Val.select, cmove, cmoveu; simpl. + all: destruct (rs x0); simpl; trivial. + all: try rewrite int_ltu_to_neq. + all: try rewrite int64_ltu_to_neq. + all: try change (Int64.eq Int64.zero Int64.zero) with true. + all: try destruct Archi.ptr64. + all: try rewrite Pregmap.gss. + all: repeat rewrite if_neg. + all: simpl. + all: try destruct (_ || _). + all: try apply Val.lessdef_normalize. + all: trivial. (* no more lessdef *) + all: apply Pregmap.gso; congruence. + +- (* Osellimm *) + unfold conditional_move_imm64 in *. + destruct c0; simpl in *. + + all: destruct c. + all: simpl in *. + all: inv EQ0. + all: econstructor; splitall. + all: try apply exec_straight_one. + all: intros; simpl; trivial. + all: unfold Val.select, cmove, cmoveu; simpl. + all: destruct (rs x0); simpl; trivial. + all: try rewrite int_ltu_to_neq. + all: try rewrite int64_ltu_to_neq. + all: try change (Int64.eq Int64.zero Int64.zero) with true. + all: try destruct Archi.ptr64. + all: try rewrite Pregmap.gss. + all: repeat rewrite if_neg. + all: simpl. + all: try destruct (_ || _). + all: try apply Val.lessdef_normalize. + all: trivial. (* no more lessdef *) + all: apply Pregmap.gso; congruence. Qed. (** Memory accesses *) @@ -1984,40 +1662,13 @@ Proof. + econstructor; econstructor; econstructor; econstructor; split. apply exec_straight_opt_refl. split; auto. simpl. subst imm. rewrite Ptrofs.of_int64_to_int64 by auto. auto. -(* -+ econstructor; econstructor; econstructor; split. - constructor. eapply exec_straight_two. - simpl; eauto. simpl; eauto. auto. auto. - split; intros; Simpl. destruct (rs base); auto; simpl. rewrite SF. simpl. - rewrite Ptrofs.add_assoc. f_equal. f_equal. - rewrite <- (Ptrofs.of_int64_to_int64 SF ofs). rewrite EQ. - symmetry; auto with ptrofs. -+ econstructor; econstructor; econstructor; split. - constructor. eapply exec_straight_two. - simpl; eauto. simpl; eauto. auto. auto. - split; intros; Simpl. unfold eval_offset. destruct (rs base); auto; simpl. rewrite SF. simpl. - rewrite Ptrofs.add_zero. subst imm. rewrite Ptrofs.of_int64_to_int64 by auto. auto. -(* 32 bits part, irrelevant for us -- generalize (make_immed32_sound (Ptrofs.to_int ofs)); intros EQ. - destruct (make_immed32 (Ptrofs.to_int ofs)). -+ econstructor; econstructor; econstructor; split. - apply exec_straight_opt_refl. - split; auto. simpl. subst imm. rewrite Ptrofs.of_int_to_int by auto. auto. -+ econstructor; econstructor; econstructor; split. - constructor. eapply exec_straight_two. - simpl; eauto. simpl; eauto. auto. auto. - split; intros; Simpl. destruct (rs base); auto; simpl. rewrite SF. simpl. - rewrite Ptrofs.add_assoc. f_equal. f_equal. - rewrite <- (Ptrofs.of_int_to_int SF ofs). rewrite EQ. - symmetry; auto with ptrofs. -*)*) Qed. Lemma indexed_load_access_correct: - forall chunk (mk_instr: ireg -> offset -> basic) rd m, + forall trap chunk (mk_instr: ireg -> offset -> basic) rd m, (forall base ofs rs, - exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset chunk rs m rd base ofs) -> + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset trap chunk rs m rd base ofs) -> forall (base: ireg) ofs k (rs: regset) v, Mem.loadv chunk m (Val.offset_ptr rs#base ofs) = Some v -> exists rs', @@ -2070,7 +1721,7 @@ Proof. /\ c = indexed_memory_access mk_instr base ofs :: k /\ forall base' ofs' rs', exec_basic_instr ge (mk_instr base' ofs') rs' m = - exec_load_offset (chunk_of_type ty) rs' m rd base' ofs'). + exec_load_offset TRAP (chunk_of_type ty) rs' m rd base' ofs'). { unfold loadind in TR. destruct ty, (preg_of dst); inv TR; econstructor; esplit; eauto. } destruct A as (mk_instr & rd & rdEq & B & C). subst c. rewrite rdEq. @@ -2138,7 +1789,9 @@ Lemma loadind_ptr_correct: /\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r. Proof. intros. eapply indexed_load_access_correct; eauto with asmgen. - intros. unfold Mptr. assert (Archi.ptr64 = true). auto. rewrite H0. auto. + intros. unfold Mptr. assert (Archi.ptr64 = true). auto. rewrite H0. + instantiate (1 := TRAP). + auto. Qed. Lemma storeind_ptr_correct: @@ -2231,11 +1884,11 @@ Proof. Qed. Lemma transl_load_access2_correct: - forall chunk (mk_instr: ireg -> ireg -> basic) addr args k c rd (rs: regset) m v mro mr1 ro v', + forall trap chunk (mk_instr: ireg -> ireg -> basic) addr args k c rd (rs: regset) m v mro mr1 ro v', args = mr1 :: mro :: nil -> ireg_of mro = OK ro -> (forall base rs, - exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg chunk rs m rd base ro) -> + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg trap chunk rs m rd base ro) -> transl_memory_access2 mk_instr addr args k = OK c -> eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> Mem.loadv chunk m v = Some v' -> @@ -2253,12 +1906,35 @@ Proof. split; intros; Simpl. auto. Qed. +Lemma transl_load_access2_correct_notrap2: + forall chunk (mk_instr: ireg -> ireg -> basic) addr args k c rd (rs: regset) m v mro mr1 ro, + args = mr1 :: mro :: nil -> + ireg_of mro = OK ro -> + (forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg NOTRAP chunk rs m rd base ro) -> + transl_memory_access2 mk_instr addr args k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> + Mem.loadv chunk m v = None -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ rs'#rd = concrete_default_notrap_load_value chunk + /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. +Proof. + intros until ro; intros ARGS IREGE INSTR TR EV LOAD. + exploit transl_memory_access2_correct; eauto. + intros (base & ro2 & mro2 & mr2 & rs' & ARGSS & IREGEQ & A & B & C). rewrite ARGSS in ARGS. inversion ARGS. subst mr2 mro2. clear ARGS. + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. assert (ro = ro2) by congruence. subst ro2. + rewrite INSTR. unfold exec_load_reg. unfold parexec_load_reg. rewrite B, LOAD. reflexivity. Simpl. + split; intros; Simpl. auto. +Qed. + Lemma transl_load_access2XS_correct: - forall chunk (mk_instr: ireg -> ireg -> basic) (scale : Z) args k c rd (rs: regset) m v mro mr1 ro v', + forall trap chunk (mk_instr: ireg -> ireg -> basic) (scale : Z) args k c rd (rs: regset) m v mro mr1 ro v', args = mr1 :: mro :: nil -> ireg_of mro = OK ro -> (forall base rs, - exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs chunk rs m rd base ro) -> + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs trap chunk rs m rd base ro) -> transl_memory_access2XS chunk mk_instr scale args k = OK c -> eval_addressing ge rs#SP (Aindexed2XS scale) (map rs (map preg_of args)) = Some v -> Mem.loadv chunk m v = Some v' -> @@ -2276,13 +1952,39 @@ Proof. unfold scale_of_chunk. subst scale. rewrite B, LOAD. reflexivity. Simpl. - split; intros; Simpl. auto. + split. trivial. intros. Simpl. +Qed. + +Lemma transl_load_access2XS_correct_notrap2: + forall chunk (mk_instr: ireg -> ireg -> basic) (scale : Z) args k c rd (rs: regset) m v mro mr1 ro, + args = mr1 :: mro :: nil -> + ireg_of mro = OK ro -> + (forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs NOTRAP chunk rs m rd base ro) -> + transl_memory_access2XS chunk mk_instr scale args k = OK c -> + eval_addressing ge rs#SP (Aindexed2XS scale) (map rs (map preg_of args)) = Some v -> + Mem.loadv chunk m v = None -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ rs'#rd = concrete_default_notrap_load_value chunk + /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. +Proof. + intros until ro; intros ARGS IREGE INSTR TR EV LOAD. + exploit transl_memory_access2XS_correct; eauto. + intros (base & ro2 & mro2 & mr2 & rs' & ARGSS & IREGEQ & A & B & C & D). rewrite ARGSS in ARGS. inversion ARGS. subst mr2 mro2. clear ARGS. + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. assert (ro = ro2) by congruence. subst ro2. + rewrite INSTR. unfold exec_load_regxs. unfold parexec_load_regxs. + unfold scale_of_chunk. + subst scale. + rewrite B, LOAD. reflexivity. Simpl. + split. trivial. intros. Simpl. Qed. Lemma transl_load_access_correct: - forall chunk (mk_instr: ireg -> offset -> basic) addr args k c rd (rs: regset) m v v', + forall trap chunk (mk_instr: ireg -> offset -> basic) addr args k c rd (rs: regset) m v v', (forall base ofs rs, - exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset chunk rs m rd base ofs) -> + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset trap chunk rs m rd base ofs) -> transl_memory_access mk_instr addr args k = OK c -> eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> Mem.loadv chunk m v = Some v' -> @@ -2300,54 +2002,119 @@ Proof. split; intros; Simpl. auto. Qed. +Lemma transl_load_access_correct_notrap2: + forall chunk (mk_instr: ireg -> offset -> basic) addr args k c rd (rs: regset) m v, + (forall base ofs rs, + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset NOTRAP chunk rs m rd base ofs) -> + transl_memory_access mk_instr addr args k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> + Mem.loadv chunk m v = None -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ rs'#rd = concrete_default_notrap_load_value chunk + /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. +Proof. + intros until v; intros INSTR TR EV LOAD. + exploit transl_memory_access_correct; eauto. + intros (base & ofs & rs' & ptr & A & PtrEq & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. + rewrite INSTR. unfold exec_load_offset. unfold parexec_load_offset. rewrite PtrEq, B, LOAD. reflexivity. Simpl. + split. trivial. intros. Simpl. +Qed. + Lemma transl_load_memory_access_ok: - forall addr chunk args dst k c rs a v m, + forall addr trap chunk args dst k c rs a v m, (match addr with Aindexed2XS _ | Aindexed2 => False | _ => True end) -> - transl_load chunk addr args dst k = OK c -> + transl_load trap chunk addr args dst k = OK c -> eval_addressing ge (rs (IR SP)) addr (map rs (map preg_of args)) = Some a -> Mem.loadv chunk m a = Some v -> exists mk_instr rd, preg_of dst = IR rd /\ transl_memory_access mk_instr addr args k = OK c /\ forall base ofs rs, - exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset chunk rs m rd base ofs. + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset trap chunk rs m rd base ofs. Proof. intros until m. intros ADDR TR ? ?. unfold transl_load in TR. destruct addr; try contradiction. - monadInv TR. destruct chunk; ArgsInv; econstructor; (esplit; eauto). - monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split; - [ instantiate (1 := (PLoadRRO _ x)); simpl; reflexivity + [ instantiate (1 := (PLoadRRO _ _ x)); simpl; reflexivity | eauto ]. - monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split; - [ instantiate (1 := (PLoadRRO _ x)); simpl; reflexivity + [ instantiate (1 := (PLoadRRO _ _ x)); simpl; reflexivity | eauto ]. Qed. -Lemma transl_load_memory_access2_ok: - forall addr chunk args dst k c rs a v m, - addr = Aindexed2 -> - transl_load chunk addr args dst k = OK c -> +Lemma transl_load_memory_access_ok_notrap2: + forall addr chunk args dst k c rs a m, + (match addr with Aindexed2XS _ | Aindexed2 => False | _ => True end) -> + transl_load NOTRAP chunk addr args dst k = OK c -> eval_addressing ge (rs (IR SP)) addr (map rs (map preg_of args)) = Some a -> + Mem.loadv chunk m a = None -> + exists mk_instr rd, + preg_of dst = IR rd + /\ transl_memory_access mk_instr addr args k = OK c + /\ forall base ofs rs, + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset NOTRAP chunk rs m rd base ofs. +Proof. + intros until m. intros ADDR TR ? ?. + unfold transl_load in TR. destruct addr; try contradiction. + - monadInv TR. destruct chunk; ArgsInv; econstructor; (esplit; eauto). + - monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split; + [ instantiate (1 := (PLoadRRO _ _ x)); simpl; reflexivity + | eauto ]. + - monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split; + [ instantiate (1 := (PLoadRRO _ _ x)); simpl; reflexivity + | eauto ]. +Qed. + +Lemma transl_load_memory_access2_ok: + forall trap chunk args dst k c rs a v m, + transl_load trap chunk Aindexed2 args dst k = OK c -> + eval_addressing ge (rs (IR SP)) Aindexed2 (map rs (map preg_of args)) = Some a -> Mem.loadv chunk m a = Some v -> exists mk_instr mr0 mro rd ro, args = mr0 :: mro :: nil /\ preg_of dst = IR rd /\ preg_of mro = IR ro - /\ transl_memory_access2 mk_instr addr args k = OK c + /\ transl_memory_access2 mk_instr Aindexed2 args k = OK c /\ forall base rs, - exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg chunk rs m rd base ro. + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg trap chunk rs m rd base ro. Proof. - intros until m. intros ? TR ? ?. + intros until m. intros TR ? ?. + unfold transl_load in TR. subst. monadInv TR. destruct chunk. all: + unfold transl_memory_access2 in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; + [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity + | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRR _ _ x)); simpl; reflexivity + | eauto]. +Qed. + + +Lemma transl_load_memory_access2_ok_notrap2: + forall chunk args dst k c rs a m, + transl_load NOTRAP chunk Aindexed2 args dst k = OK c -> + eval_addressing ge (rs (IR SP)) Aindexed2 (map rs (map preg_of args)) = Some a -> + Mem.loadv chunk m a = None -> + exists mk_instr mr0 mro rd ro, + args = mr0 :: mro :: nil + /\ preg_of dst = IR rd + /\ preg_of mro = IR ro + /\ transl_memory_access2 mk_instr Aindexed2 args k = OK c + /\ forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg NOTRAP chunk rs m rd base ro. +Proof. + intros until m. intros TR ? ?. unfold transl_load in TR. subst. monadInv TR. destruct chunk. all: unfold transl_memory_access2 in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity - | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRR _ x)); simpl; reflexivity + | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRR _ _ x)); simpl; reflexivity | eauto]. Qed. Lemma transl_load_memory_access2XS_ok: - forall scale chunk args dst k c rs a v m, - transl_load chunk (Aindexed2XS scale) args dst k = OK c -> + forall scale trap chunk args dst k c rs a v m, + transl_load trap chunk (Aindexed2XS scale) args dst k = OK c -> eval_addressing ge (rs (IR SP)) (Aindexed2XS scale) (map rs (map preg_of args)) = Some a -> Mem.loadv chunk m a = Some v -> exists mk_instr mr0 mro rd ro, @@ -2356,19 +2123,41 @@ Lemma transl_load_memory_access2XS_ok: /\ preg_of mro = IR ro /\ transl_memory_access2XS chunk mk_instr scale args k = OK c /\ forall base rs, - exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs chunk rs m rd base ro. + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs trap chunk rs m rd base ro. Proof. intros until m. intros TR ? ?. unfold transl_load in TR. subst. monadInv TR. destruct chunk. all: unfold transl_memory_access2XS in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity - | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRRXS _ x)); simpl; rewrite Heqb; eauto + | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRRXS _ _ x)); simpl; rewrite Heqb; eauto + | eauto]. +Qed. + + +Lemma transl_load_memory_access2XS_ok_notrap2: + forall scale chunk args dst k c rs a m, + transl_load NOTRAP chunk (Aindexed2XS scale) args dst k = OK c -> + eval_addressing ge (rs (IR SP)) (Aindexed2XS scale) (map rs (map preg_of args)) = Some a -> + Mem.loadv chunk m a = None -> + exists mk_instr mr0 mro rd ro, + args = mr0 :: mro :: nil + /\ preg_of dst = IR rd + /\ preg_of mro = IR ro + /\ transl_memory_access2XS chunk mk_instr scale args k = OK c + /\ forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs NOTRAP chunk rs m rd base ro. +Proof. + intros until m. intros TR ? ?. + unfold transl_load in TR. subst. monadInv TR. destruct chunk. all: + unfold transl_memory_access2XS in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; + [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity + | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRRXS _ _ x)); simpl; rewrite Heqb; eauto | eauto]. Qed. Lemma transl_load_correct: - forall chunk addr args dst k c (rs: regset) m a v, - transl_load chunk addr args dst k = OK c -> + forall trap chunk addr args dst k c (rs: regset) m a v, + transl_load trap chunk addr args dst k = OK c -> eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a -> Mem.loadv chunk m a = Some v -> exists rs', @@ -2392,6 +2181,32 @@ Proof. eapply transl_load_access_correct; eauto with asmgen. Qed. +Lemma transl_load_correct_notrap2: + forall chunk addr args dst k c (rs: regset) m a, + transl_load NOTRAP chunk addr args dst k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a -> + Mem.loadv chunk m a = None -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ rs'#(preg_of dst) = (concrete_default_notrap_load_value chunk) + /\ forall r, r <> PC -> r <> RTMP -> r <> preg_of dst -> rs'#r = rs#r. +Proof. + intros until a; intros TR EV LOAD. destruct addr. + - exploit transl_load_memory_access2XS_ok_notrap2; eauto. intros (mk_instr & mr0 & mro & rd & ro & argsEq & rdEq & roEq & B & C). + rewrite rdEq. eapply transl_load_access2XS_correct_notrap2; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. + - exploit transl_load_memory_access2_ok_notrap2; eauto. intros (mk_instr & mr0 & mro & rd & ro & argsEq & rdEq & roEq & B & C). + rewrite rdEq. eapply transl_load_access2_correct_notrap2; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. + - exploit transl_load_memory_access_ok_notrap2; eauto; try discriminate; try (simpl; reflexivity). + intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; + eapply transl_load_access_correct_notrap2; eauto with asmgen. + - exploit transl_load_memory_access_ok_notrap2; eauto; try discriminate; try (simpl; reflexivity). + intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; + eapply transl_load_access_correct_notrap2; eauto with asmgen. + - exploit transl_load_memory_access_ok_notrap2; eauto; try discriminate; try (simpl; reflexivity). + intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; + eapply transl_load_access_correct_notrap2; eauto with asmgen. +Qed. + Lemma transl_store_access2_correct: forall chunk (mk_instr: ireg -> ireg -> basic) addr args k c r1 (rs: regset) m v mr1 mro ro m', args = mr1 :: mro :: nil -> @@ -2671,8 +2486,8 @@ Proof. { eapply A2. } { apply exec_straight_one. simpl. rewrite (C2 SP) by auto with asmgen. rewrite <- (sp_val _ _ rs1 AG1). simpl; rewrite LP'. - rewrite FREE'. eauto. (* auto. *) } } - * split. (* apply agree_nextinstr. *)apply agree_set_other; auto with asmgen. + rewrite FREE'. eauto. } } + * split. apply agree_set_other; auto with asmgen. apply agree_change_sp with (Vptr stk soff). apply agree_exten with rs; auto. intros; rewrite C2; auto with asmgen. eapply parent_sp_def; eauto. diff --git a/mppa_k1c/Asmblockprops.v b/mppa_k1c/Asmblockprops.v new file mode 100644 index 00000000..3c6ba534 --- /dev/null +++ b/mppa_k1c/Asmblockprops.v @@ -0,0 +1,343 @@ +(** Common definition and proofs on Asmblock required by various modules *) + +Require Import Coqlib. +Require Import Integers. +Require Import Memory. +Require Import Globalenvs. +Require Import Values. +Require Import Asmblock. +Require Import Axioms. + +Definition bblock_simu (ge: Genv.t fundef unit) (f: function) (bb bb': bblock) := + forall rs m, + exec_bblock ge f bb rs m <> Stuck -> + exec_bblock ge f bb rs m = exec_bblock ge f bb' rs m. + +Hint Extern 2 (_ <> _) => congruence: asmgen. + +Lemma preg_of_data: + forall r, data_preg (preg_of r) = true. +Proof. + intros. destruct r; reflexivity. +Qed. +Hint Resolve preg_of_data: asmgen. + +Lemma data_diff: + forall r r', + data_preg r = true -> data_preg r' = false -> r <> r'. +Proof. + congruence. +Qed. +Hint Resolve data_diff: asmgen. + +Lemma preg_of_not_PC: + forall r, preg_of r <> PC. +Proof. + intros. apply data_diff; auto with asmgen. +Qed. + +Lemma preg_of_not_SP: + forall r, preg_of r <> SP. +Proof. + intros. unfold preg_of; destruct r; simpl; congruence. +Qed. + +Hint Resolve preg_of_not_SP preg_of_not_PC: asmgen. + + +Lemma nextblock_pc: + forall b rs, (nextblock b rs)#PC = Val.offset_ptr rs#PC (Ptrofs.repr (size b)). +Proof. + intros. apply Pregmap.gss. +Qed. + +Lemma nextblock_inv: + forall b r rs, r <> PC -> (nextblock b rs)#r = rs#r. +Proof. + intros. unfold nextblock. apply Pregmap.gso. red; intro; subst. auto. +Qed. + +Lemma nextblock_inv1: + forall b r rs, data_preg r = true -> (nextblock b rs)#r = rs#r. +Proof. + intros. apply nextblock_inv. red; intro; subst; discriminate. +Qed. + +Ltac Simplif := + ((rewrite nextblock_inv by eauto with asmgen) + || (rewrite nextblock_inv1 by eauto with asmgen) + || (rewrite Pregmap.gss) + || (rewrite nextblock_pc) + || (rewrite Pregmap.gso by eauto with asmgen) + ); auto with asmgen. + +Ltac Simpl := repeat Simplif. + +(* For Asmblockgenproof0 *) + +Theorem exec_basic_instr_pc: + forall ge b rs1 m1 rs2 m2, + exec_basic_instr ge b rs1 m1 = Next rs2 m2 -> + rs2 PC = rs1 PC. +Proof. + intros. destruct b; try destruct i; try destruct i. + all: try (inv H; Simpl). + 1-10: unfold parexec_load_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail. + + 1-20: unfold parexec_load_reg, parexec_load_regxs in H1; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail. + + { (* PLoadQRRO *) + unfold parexec_load_q_offset in H1. + destruct (gpreg_q_expand _) as [r0 r1] in H1. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + inv H1. Simpl. } + { (* PLoadORRO *) + unfold parexec_load_o_offset in H1. + destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + inv H1. Simpl. } + 1-8: unfold parexec_store_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]; fail. + 1-8: unfold parexec_store_reg in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail. + 1-8: unfold parexec_store_regxs in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail. + + { (* PStoreQRRO *) + unfold parexec_store_q_offset in H1. + destruct (gpreg_q_expand _) as [r0 r1] in H1. + unfold eval_offset in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + inv H1. Simpl. reflexivity. } + { (* PStoreORRO *) + unfold parexec_store_o_offset in H1. + destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. + unfold eval_offset in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + inv H1. Simpl. reflexivity. } + - destruct (Mem.alloc _ _ _). destruct (Mem.store _ _ _ _ _). inv H1. Simpl. discriminate. + - destruct (Mem.loadv _ _ _); try discriminate. destruct (rs1 _); try discriminate. + destruct (Mem.free _ _ _ _). inv H1. Simpl. discriminate. + - destruct rs; try discriminate. inv H1. Simpl. + - destruct rd; try discriminate. inv H1; Simpl. + - reflexivity. +Qed. + +(* For PostpassSchedulingproof *) + +Lemma regset_double_set: + forall r1 r2 (rs: regset) v1 v2, + r1 <> r2 -> + (rs # r1 <- v1 # r2 <- v2) = (rs # r2 <- v2 # r1 <- v1). +Proof. + intros. apply functional_extensionality. intros r. destruct (preg_eq r r1). + - subst. rewrite Pregmap.gso; auto. repeat (rewrite Pregmap.gss). auto. + - destruct (preg_eq r r2). + + subst. rewrite Pregmap.gss. rewrite Pregmap.gso; auto. rewrite Pregmap.gss. auto. + + repeat (rewrite Pregmap.gso; auto). +Qed. + +Lemma next_eq: + forall (rs rs': regset) m m', + rs = rs' -> m = m' -> Next rs m = Next rs' m'. +Proof. + intros; apply f_equal2; auto. +Qed. + +Lemma exec_load_offset_pc_var: + forall trap t rs m rd ra ofs rs' m' v, + exec_load_offset trap t rs m rd ra ofs = Next rs' m' -> + exec_load_offset trap t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_load_offset in *. unfold parexec_load_offset in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ofs); try discriminate. + destruct (Mem.loadv _ _ _). + - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. + - unfold parexec_incorrect_load in *. + destruct trap; try discriminate. + inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. +Qed. + +Lemma exec_load_reg_pc_var: + forall trap t rs m rd ra ro rs' m' v, + exec_load_reg trap t rs m rd ra ro = Next rs' m' -> + exec_load_reg trap t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_load_reg in *. unfold parexec_load_reg in *. rewrite Pregmap.gso; try discriminate. + destruct (Mem.loadv _ _ _). + - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. + - unfold parexec_incorrect_load in *. + destruct trap; try discriminate. + inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. +Qed. + +Lemma exec_load_regxs_pc_var: + forall trap t rs m rd ra ro rs' m' v, + exec_load_regxs trap t rs m rd ra ro = Next rs' m' -> + exec_load_regxs trap t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_load_regxs in *. unfold parexec_load_regxs in *. rewrite Pregmap.gso; try discriminate. + destruct (Mem.loadv _ _ _). + - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. + - unfold parexec_incorrect_load in *. + destruct trap; try discriminate. + inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. +Qed. + +Lemma exec_load_offset_q_pc_var: + forall rs m rd ra ofs rs' m' v, + exec_load_q_offset rs m rd ra ofs = Next rs' m' -> + exec_load_q_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_load_q_offset in *. unfold parexec_load_q_offset in *. + destruct (gpreg_q_expand rd) as [rd0 rd1]. + (* destruct (ireg_eq rd0 ra); try discriminate. *) + rewrite Pregmap.gso; try discriminate. + destruct (Mem.loadv _ _ _); try discriminate. + inv H. + destruct (Mem.loadv _ _ _); try discriminate. + inv H1. f_equal. + rewrite (regset_double_set PC rd0) by discriminate. + rewrite (regset_double_set PC rd1) by discriminate. + reflexivity. +Qed. + +Lemma exec_load_offset_o_pc_var: + forall rs m rd ra ofs rs' m' v, + exec_load_o_offset rs m rd ra ofs = Next rs' m' -> + exec_load_o_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_load_o_offset in *. unfold parexec_load_o_offset in *. + destruct (gpreg_o_expand rd) as [[[rd0 rd1] rd2] rd3]. +(* + destruct (ireg_eq rd0 ra); try discriminate. + destruct (ireg_eq rd1 ra); try discriminate. + destruct (ireg_eq rd2 ra); try discriminate. +*) + rewrite Pregmap.gso; try discriminate. + simpl in *. + destruct (Mem.loadv _ _ _); try discriminate. + destruct (Mem.loadv _ _ _); try discriminate. + destruct (Mem.loadv _ _ _); try discriminate. + destruct (Mem.loadv _ _ _); try discriminate. + rewrite (regset_double_set PC rd0) by discriminate. + rewrite (regset_double_set PC rd1) by discriminate. + rewrite (regset_double_set PC rd2) by discriminate. + rewrite (regset_double_set PC rd3) by discriminate. + inv H. + trivial. +Qed. + +Lemma exec_store_offset_pc_var: + forall t rs m rd ra ofs rs' m' v, + exec_store_offset t rs m rd ra ofs = Next rs' m' -> + exec_store_offset t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_store_offset in *. unfold parexec_store_offset in *. rewrite Pregmap.gso; try discriminate. + destruct (eval_offset ofs); try discriminate. + destruct (Mem.storev _ _ _). + - inv H. apply next_eq; auto. + - discriminate. +Qed. + +Lemma exec_store_q_offset_pc_var: + forall rs m rd ra ofs rs' m' v, + exec_store_q_offset rs m rd ra ofs = Next rs' m' -> + exec_store_q_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_store_q_offset in *. unfold parexec_store_q_offset in *. rewrite Pregmap.gso; try discriminate. + simpl in *. + destruct (gpreg_q_expand _) as [s0 s1]. + destruct (Mem.storev _ _ _); try discriminate. + destruct (Mem.storev _ _ _); try discriminate. + inv H. apply next_eq; auto. +Qed. + +Lemma exec_store_o_offset_pc_var: + forall rs m rd ra ofs rs' m' v, + exec_store_o_offset rs m rd ra ofs = Next rs' m' -> + exec_store_o_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. + unfold exec_store_o_offset in *. unfold parexec_store_o_offset in *. + destruct (gpreg_o_expand _) as [[[s0 s1] s2] s3]. + destruct (Mem.storev _ _ _); try discriminate. + destruct (Mem.storev _ _ _); try discriminate. + destruct (Mem.storev _ _ _); try discriminate. + destruct (Mem.storev _ _ _); try discriminate. + inv H. + trivial. +Qed. + +Lemma exec_store_reg_pc_var: + forall t rs m rd ra ro rs' m' v, + exec_store_reg t rs m rd ra ro = Next rs' m' -> + exec_store_reg t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_store_reg in *. unfold parexec_store_reg in *. rewrite Pregmap.gso; try discriminate. + destruct (Mem.storev _ _ _). + - inv H. apply next_eq; auto. + - discriminate. +Qed. + +Lemma exec_store_regxs_pc_var: + forall t rs m rd ra ro rs' m' v, + exec_store_regxs t rs m rd ra ro = Next rs' m' -> + exec_store_regxs t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_store_regxs in *. unfold parexec_store_regxs in *. rewrite Pregmap.gso; try discriminate. + destruct (Mem.storev _ _ _). + - inv H. apply next_eq; auto. + - discriminate. +Qed. + +Theorem exec_basic_instr_pc_var: + forall ge i rs m rs' m' v, + exec_basic_instr ge i rs m = Next rs' m' -> + exec_basic_instr ge i (rs # PC <- v) m = Next (rs' # PC <- v) m'. +Proof. + intros. unfold exec_basic_instr in *. unfold bstep in *. destruct i. + - unfold exec_arith_instr in *. destruct i; destruct i. + all: try (exploreInst; inv H; apply next_eq; auto; + apply functional_extensionality; intros; rewrite regset_double_set; auto; discriminate). +(* + (* Some cases treated seperately because exploreInst destructs too much *) + all: try (inv H; apply next_eq; auto; apply functional_extensionality; intros; rewrite regset_double_set; auto; discriminate). *) + - destruct i. + + exploreInst; apply exec_load_offset_pc_var; auto. + + exploreInst; apply exec_load_reg_pc_var; auto. + + exploreInst; apply exec_load_regxs_pc_var; auto. + + apply exec_load_offset_q_pc_var; auto. + + apply exec_load_offset_o_pc_var; auto. + - destruct i. + + exploreInst; apply exec_store_offset_pc_var; auto. + + exploreInst; apply exec_store_reg_pc_var; auto. + + exploreInst; apply exec_store_regxs_pc_var; auto. + + apply exec_store_q_offset_pc_var; auto. + + apply exec_store_o_offset_pc_var; auto. + - destruct (Mem.alloc _ _ _) as (m1 & stk). repeat (rewrite Pregmap.gso; try discriminate). + destruct (Mem.storev _ _ _ _); try discriminate. + inv H. apply next_eq; auto. apply functional_extensionality. intros. + rewrite (regset_double_set GPR32 PC); try discriminate. + rewrite (regset_double_set GPR12 PC); try discriminate. + rewrite (regset_double_set FP PC); try discriminate. reflexivity. + - repeat (rewrite Pregmap.gso; try discriminate). + destruct (Mem.loadv _ _ _); try discriminate. + destruct (rs GPR12); try discriminate. + destruct (Mem.free _ _ _ _); try discriminate. + inv H. apply next_eq; auto. + rewrite (regset_double_set GPR32 PC). + rewrite (regset_double_set GPR12 PC). reflexivity. + all: discriminate. + - destruct rs0; try discriminate. inv H. apply next_eq; auto. + repeat (rewrite Pregmap.gso; try discriminate). apply regset_double_set; discriminate. + - destruct rd; try discriminate. inv H. apply next_eq; auto. + repeat (rewrite Pregmap.gso; try discriminate). apply regset_double_set; discriminate. + - inv H. apply next_eq; auto. +Qed. + + diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 65dee6c7..8ab10bc5 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -190,10 +190,10 @@ let expand_builtin_memcpy_big sz al src dst = end); cpy tmpbuf2 16L (fun x y z -> Plq(x, y, z)) (fun x y z -> Psq(x, y, z)); - cpy tmpbuf 8L (fun x y z -> Pld(x, y, z)) (fun x y z -> Psd(x, y, z)); - cpy tmpbuf 4L (fun x y z -> Plw(x, y, z)) (fun x y z -> Psw(x, y, z)); - cpy tmpbuf 2L (fun x y z -> Plh(x, y, z)) (fun x y z -> Psh(x, y, z)); - cpy tmpbuf 1L (fun x y z -> Plb(x, y, z)) (fun x y z -> Psb(x, y, z)); + cpy tmpbuf 8L (fun x y z -> Pld(TRAP, x, y, z)) (fun x y z -> Psd(x, y, z)); + cpy tmpbuf 4L (fun x y z -> Plw(TRAP, x, y, z)) (fun x y z -> Psw(x, y, z)); + cpy tmpbuf 2L (fun x y z -> Plh(TRAP, x, y, z)) (fun x y z -> Psh(x, y, z)); + cpy tmpbuf 1L (fun x y z -> Plb(TRAP, x, y, z)) (fun x y z -> Psb(x, y, z)); assert (!remaining = 0L) end else @@ -203,7 +203,7 @@ let expand_builtin_memcpy_big sz al src dst = let lbl = new_label() in emit (Ploopdo (tmpbuf, lbl)); emit Psemi; - emit (Plb (tmpbuf, srcptr, AOff Z.zero)); + emit (Plb (TRAP, tmpbuf, srcptr, AOff Z.zero)); emit (Paddil (srcptr, srcptr, Z.one)); emit Psemi; emit (Psb (tmpbuf, dstptr, AOff Z.zero)); @@ -223,30 +223,30 @@ let expand_builtin_memcpy sz al args = let expand_builtin_vload_common chunk base ofs res = match chunk, res with | Mint8unsigned, BR(Asmvliw.IR res) -> - emit (Plbu (res, base, AOff ofs)) + emit (Plbu (TRAP, res, base, AOff ofs)) | Mint8signed, BR(Asmvliw.IR res) -> - emit (Plb (res, base, AOff ofs)) + emit (Plb (TRAP, res, base, AOff ofs)) | Mint16unsigned, BR(Asmvliw.IR res) -> - emit (Plhu (res, base, AOff ofs)) + emit (Plhu (TRAP, res, base, AOff ofs)) | Mint16signed, BR(Asmvliw.IR res) -> - emit (Plh (res, base, AOff ofs)) + emit (Plh (TRAP, res, base, AOff ofs)) | Mint32, BR(Asmvliw.IR res) -> - emit (Plw (res, base, AOff ofs)) + emit (Plw (TRAP, res, base, AOff ofs)) | Mint64, BR(Asmvliw.IR res) -> - emit (Pld (res, base, AOff ofs)) + emit (Pld (TRAP, res, base, AOff ofs)) | Mint64, BR_splitlong(BR(Asmvliw.IR res1), BR(Asmvliw.IR res2)) -> let ofs' = Integers.Ptrofs.add ofs _4 in if base <> res2 then begin - emit (Plw (res2, base, AOff ofs)); - emit (Plw (res1, base, AOff ofs')) + emit (Plw (TRAP, res2, base, AOff ofs)); + emit (Plw (TRAP, res1, base, AOff ofs')) end else begin - emit (Plw (res1, base, AOff ofs')); - emit (Plw (res2, base, AOff ofs)) + emit (Plw (TRAP, res1, base, AOff ofs')); + emit (Plw (TRAP, res2, base, AOff ofs)) end | Mfloat32, BR(Asmvliw.IR res) -> - emit (Pfls (res, base, AOff ofs)) + emit (Pfls (TRAP, res, base, AOff ofs)) | Mfloat64, BR(Asmvliw.IR res) -> - emit (Pfld (res, base, AOff ofs)) + emit (Pfld (TRAP, res, base, AOff ofs)) | _ -> assert false @@ -345,34 +345,32 @@ let expand_int64_arith conflict rl fn = assert false (* Byte swaps. There are no specific instructions, so we use standard, not-very-efficient formulas. *) -let expand_bswap16 d s = assert false +let expand_bswap16 d s = let open Asmvliw in (* d = (s & 0xFF) << 8 | (s >> 8) & 0xFF *) -(*emit (Pandiw(X31, X s, coqint_of_camlint 0xFFl)); - emit (Pslliw(X31, X X31, _8)); - emit (Psrliw(d, X s, _8)); - emit (Pandiw(d, X d, coqint_of_camlint 0xFFl)); - emit (Porw(d, X X31, X d)) -*) + emit (Pandiw(GPR32, s, coqint_of_camlint 0xFFl)); emit Psemi; + emit (Pslliw(GPR32, GPR32, _8)); emit Psemi; + emit (Psrliw(d, s, _8)); emit Psemi; + emit (Pandiw(d, d, coqint_of_camlint 0xFFl)); + emit (Porw(d, GPR32, d)); emit Psemi -let expand_bswap32 d s = assert false +let expand_bswap32 d s = let open Asmvliw in (* d = (s << 24) | (((s >> 8) & 0xFF) << 16) | (((s >> 16) & 0xFF) << 8) | (s >> 24) *) -(*emit (Pslliw(X1, X s, coqint_of_camlint 24l)); - emit (Psrliw(X31, X s, _8)); - emit (Pandiw(X31, X X31, coqint_of_camlint 0xFFl)); - emit (Pslliw(X31, X X31, _16)); - emit (Porw(X1, X X1, X X31)); - emit (Psrliw(X31, X s, _16)); - emit (Pandiw(X31, X X31, coqint_of_camlint 0xFFl)); - emit (Pslliw(X31, X X31, _8)); - emit (Porw(X1, X X1, X X31)); - emit (Psrliw(X31, X s, coqint_of_camlint 24l)); - emit (Porw(d, X X1, X X31)) -*) - -let expand_bswap64 d s = assert false + emit (Pslliw(GPR16, s, coqint_of_camlint 24l)); emit Psemi; + emit (Psrliw(GPR32, s, _8)); emit Psemi; + emit (Pandiw(GPR32, GPR32, coqint_of_camlint 0xFFl)); emit Psemi; + emit (Pslliw(GPR32, GPR32, _16)); emit Psemi; + emit (Porw(GPR16, GPR16, GPR31)); emit Psemi; + emit (Psrliw(GPR32, s, _16)); emit Psemi; + emit (Pandiw(GPR32, GPR32, coqint_of_camlint 0xFFl)); emit Psemi; + emit (Pslliw(GPR32, GPR32, _8)); emit Psemi; + emit (Porw(GPR16, GPR16, GPR32)); emit Psemi; + emit (Psrliw(GPR32, s, coqint_of_camlint 24l)); emit Psemi; + emit (Porw(d, GPR16, GPR32)); emit Psemi + +let expand_bswap64 d s = let open Asmvliw in (* d = s << 56 | (((s >> 8) & 0xFF) << 48) | (((s >> 16) & 0xFF) << 40) @@ -381,17 +379,16 @@ let expand_bswap64 d s = assert false | (((s >> 40) & 0xFF) << 16) | (((s >> 48) & 0xFF) << 8) | s >> 56 *) -(*emit (Psllil(X1, X s, coqint_of_camlint 56l)); + emit (Psllil(GPR16, s, coqint_of_camlint 56l)); emit Psemi; List.iter (fun (n1, n2) -> - emit (Psrlil(X31, X s, coqint_of_camlint n1)); - emit (Pandil(X31, X X31, coqint_of_camlint 0xFFl)); - emit (Psllil(X31, X X31, coqint_of_camlint n2)); - emit (Porl(X1, X X1, X X31))) + emit (Psrlil(GPR32, s, coqint_of_camlint n1)); emit Psemi; + emit (Pandil(GPR32, GPR32, coqint_of_camlint 0xFFl)); emit Psemi; + emit (Psllil(GPR32, GPR32, coqint_of_camlint n2)); emit Psemi; + emit (Porl(GPR16, GPR16, GPR32)); emit Psemi;) [(8l,48l); (16l,40l); (24l,32l); (32l,24l); (40l,16l); (48l,8l)]; - emit (Psrlil(X31, X s, coqint_of_camlint 56l)); - emit (Porl(d, X X1, X X31)) -*) + emit (Psrlil(GPR32, s, coqint_of_camlint 56l)); emit Psemi; + emit (Porl(d, GPR16, GPR32)); emit Psemi (* Handling of compiler-inlined builtins *) let last_system_register = 511l @@ -465,18 +462,24 @@ let expand_builtin_inline name args res = let open Asmvliw in emit (Pitouchl addr) | "__builtin_k1_dzerol", [BA(IR addr)], _ -> emit (Pdzerol addr) - | "__builtin_k1_afaddd", [BA(IR addr); BA (IR incr_res)], BR(IR res) -> +(*| "__builtin_k1_afaddd", [BA(IR addr); BA (IR incr_res)], BR(IR res) -> (if res <> incr_res - then (emit (Pmv(res, incr_res)); emit Psemi)); + then (emit (Asm.Pmv(res, incr_res)); emit Psemi)); emit (Pafaddd(addr, res)) | "__builtin_k1_afaddw", [BA(IR addr); BA (IR incr_res)], BR(IR res) -> (if res <> incr_res - then (emit (Pmv(res, incr_res)); emit Psemi)); - emit (Pafaddw(addr, res)) + then (emit (Asm.Pmv(res, incr_res)); emit Psemi)); + emit (Pafaddw(addr, res)) *) (* see #157 *) | "__builtin_alclrd", [BA(IR addr)], BR(IR res) -> emit (Palclrd(res, addr)) | "__builtin_alclrw", [BA(IR addr)], BR(IR res) -> emit (Palclrw(res, addr)) + | "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> + expand_bswap16 res a1 + | ("__builtin_bswap"| "__builtin_bswap32"), [BA(IR a1)], BR(IR res) -> + expand_bswap32 res a1 + | "__builtin_bswap64", [BA(IR src)], BR(IR res) -> + expand_bswap64 res src (* Byte swaps *) (*| "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> @@ -504,15 +507,15 @@ let expand_instruction instr = expand_storeind_ptr Asmvliw.GPR17 stack_pointer ofs; emit Psemi; let va_ofs = - sz in - (*Z.add full_sz (Z.of_sint ((n - _nbregargs_) * wordsize)) in *) + let extra_ofs = if n <= _nbregargs_ then 0 else ((n - _nbregargs_) * wordsize) in + Z.add sz (Z.of_sint extra_ofs) in vararg_start_ofs := Some va_ofs; save_arguments n va_ofs end else begin let below = Integers.Ptrofs.repr (Z.neg sz) in expand_addptrofs stack_pointer stack_pointer below; + emit Psemi; (* Psemi required to fit in resource constraints *) expand_storeind_ptr stack_pointer stack_pointer (Integers.Ptrofs.add ofs below); - (* DM we don't need it emit Psemi; *) vararg_start_ofs := None end | Pfreeframe (sz, ofs) -> diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 58e80be1..8875a4ac 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -18,15 +18,18 @@ Require Import Integers. Require Import Mach Asm Asmblock Asmblockgen Machblockgen. Require Import PostpassScheduling. -Require Import Errors. +Require Import Errors String. +Require Compopts. Local Open Scope error_monad_scope. +Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := Compopts.time name f. + Definition transf_program (p: Mach.program) : res Asm.program := - let mbp := Machblockgen.transf_program p in - do abp <- Asmblockgen.transf_program mbp; - do abp' <- PostpassScheduling.transf_program abp; - OK (Asm.transf_program abp'). + let mbp := (time "Machblock generation" Machblockgen.transf_program) p in + do abp <- (time "Asmblock generation" Asmblockgen.transf_program) mbp; + do abp' <- (time "PostpassScheduling total oracle+verification" PostpassScheduling.transf_program) abp; + OK ((time "Asm generation" Asm.transf_program) abp'). Definition transf_function (f: Mach.function) : res Asm.function := let mbf := Machblockgen.transf_function f in diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index e7e21a18..7388f6da 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -10,7 +10,7 @@ (* *) (* *********************************************************************) -(** Correctness proof for RISC-V generation: main proof. *) +(** Correctness proof for Asmgen *) Require Import Coqlib Errors. Require Import Integers Floats AST Linking. @@ -35,7 +35,7 @@ Proof. intros p tp H. unfold Asmgen.transf_program in H. apply bind_inversion in H. destruct H. inversion_clear H. apply bind_inversion in H1. destruct H1. - inversion_clear H. inversion H2. remember (Machblockgen.transf_program p) as mbp. + inversion_clear H. inversion H2. unfold time, Compopts.time in *. remember (Machblockgen.transf_program p) as mbp. unfold match_prog; simpl. exists mbp; split. apply Machblockgenproof.transf_program_match; auto. exists x; split. apply Asmblockgenproof.transf_program_match; auto. @@ -89,4 +89,4 @@ Module Asmgenproof0. Definition return_address_offset := return_address_offset. -End Asmgenproof0.
\ No newline at end of file +End Asmgenproof0. diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 3bef1a5c..946007c1 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -17,8 +17,6 @@ (** Abstract syntax and semantics for VLIW semantics of K1c assembly language. *) -(* FIXME: develop/fix the comments in this file *) - Require Import Coqlib. Require Import Maps. Require Import AST. @@ -45,8 +43,7 @@ Require Import Chunks. this view induces our sequential semantics of bundles defined in [Asmblock]. *) -(** General Purpose registers. -*) +(** General Purpose registers. *) Inductive gpreg: Type := | GPR0: gpreg | GPR1: gpreg | GPR2: gpreg | GPR3: gpreg | GPR4: gpreg @@ -148,13 +145,10 @@ Definition gpreg_o_expand (x : gpreg_o) : gpreg * gpreg * gpreg * gpreg := | R56R57R58R59 => (GPR56, GPR57, GPR58, GPR59) | R60R61R62R63 => (GPR60, GPR61, GPR62, GPR63) end. - + Lemma gpreg_o_eq : forall (x y : gpreg_o), {x=y} + {x<>y}. Proof. decide equality. Defined. -(** We model the following registers of the RISC-V architecture. *) - -(** basic register *) Inductive preg: Type := | IR: gpreg -> preg (**r integer general purpose registers *) | RA: preg @@ -173,7 +167,7 @@ End PregEq. Module Pregmap := EMap(PregEq). -(** Conventional names for stack pointer ([SP]) and return address ([RA]). *) +(** Conventional names for stack pointer ([SP]), return address ([RA]), frame pointer ([FP]) and other temporaries used *) Notation "'SP'" := GPR12 (only parsing) : asm. Notation "'FP'" := GPR17 (only parsing) : asm. @@ -188,9 +182,7 @@ Inductive btest: Type := | BTdgez (**r Double Greater Than or Equal to Zero *) | BTdlez (**r Double Less Than or Equal to Zero *) | BTdgtz (**r Double Greater Than Zero *) -(*| BTodd (**r Odd (LSB Set) *) - | BTeven (**r Even (LSB Clear) *) -*)| BTwnez (**r Word Not Equal to Zero *) + | BTwnez (**r Word Not Equal to Zero *) | BTweqz (**r Word Equal to Zero *) | BTwltz (**r Word Less Than Zero *) | BTwgez (**r Word Greater Than or Equal to Zero *) @@ -211,11 +203,6 @@ Inductive itest: Type := | ITgeu (**r Greater Than or Equal Unsigned *) | ITleu (**r Less Than or Equal Unsigned *) | ITgtu (**r Greater Than Unsigned *) - (* Not used yet *) - | ITall (**r All Bits Set in Mask *) - | ITnall (**r Not All Bits Set in Mask *) - | ITany (**r Any Bits Set in Mask *) - | ITnone (**r Not Any Bits Set in Mask *) . Inductive ftest: Type := @@ -251,16 +238,7 @@ Definition offset : Type := ptrofs. Definition label := positive. -(* FIXME - rewrite the comment *) -(** A note on immediates: there are various constraints on immediate - operands to K1c instructions. We do not attempt to capture these - restrictions in the abstract syntax nor in the semantics. The - assembler will emit an error if immediate operands exceed the - representable range. Of course, our K1c generator (file - [Asmgen]) is careful to respect this range. *) - -(** Instructions to be expanded in control-flow -*) +(** Instructions to be expanded in control-flow *) Inductive ex_instruction : Type := (* Pseudo-instructions *) | Pbuiltin: external_function -> list (builtin_arg preg) @@ -330,6 +308,16 @@ Inductive cf_instruction : Type := . (** Loads **) +Definition concrete_default_notrap_load_value (chunk : memory_chunk) := + match chunk with + | Mint8signed | Mint8unsigned | Mint16signed | Mint16unsigned + | Mint32 => Vint Int.zero + | Mint64 => Vlong Int64.zero + | Many32 | Many64 => Vundef + | Mfloat32 => Vsingle Float32.zero + | Mfloat64 => Vfloat Float.zero + end. + Inductive load_name : Type := | Plb (**r load byte *) | Plbu (**r load byte unsigned *) @@ -344,9 +332,9 @@ Inductive load_name : Type := . Inductive ld_instruction : Type := - | PLoadRRO (i: load_name) (rd: ireg) (ra: ireg) (ofs: offset) - | PLoadRRR (i: load_name) (rd: ireg) (ra: ireg) (rofs: ireg) - | PLoadRRRXS (i: load_name) (rd: ireg) (ra: ireg) (rofs: ireg) + | PLoadRRO (trap: trapping_mode) (i: load_name) (rd: ireg) (ra: ireg) (ofs: offset) + | PLoadRRR (trap: trapping_mode) (i: load_name) (rd: ireg) (ra: ireg) (rofs: ireg) + | PLoadRRRXS (trap: trapping_mode) (i: load_name) (rd: ireg) (ra: ireg) (rofs: ireg) | PLoadQRRO (rd: gpreg_q) (ra: ireg) (ofs: offset) | PLoadORRO (rd: gpreg_o) (ra: ireg) (ofs: offset) . @@ -392,6 +380,7 @@ Inductive arith_name_rr : Type := | Pfabsw (**r float absolute word *) | Pfnegd (**r float negate double *) | Pfnegw (**r float negate word *) + | Pfinvw (**r float invert word *) | Pfnarrowdw (**r float narrow 64 -> 32 bits *) | Pfwidenlwd (**r Floating Point widen from 32 bits to 64 bits *) | Pfloatwrnsz (**r Floating Point conversion from integer (int -> SINGLE) *) @@ -429,7 +418,9 @@ Inductive arith_name_rrr : Type := | Pfcompl (ft: ftest) (**r comparison float64 *) | Paddw (**r add word *) - | Psubw (**r sub word *) + | Paddxw (shift : shift1_4) (**r add shift *) + | Psubw (**r sub word word *) + | Prevsubxw (shift : shift1_4) (**r sub shift word *) | Pmulw (**r mul word *) | Pandw (**r and word *) | Pnandw (**r nand word *) @@ -445,7 +436,9 @@ Inductive arith_name_rrr : Type := | Psllw (**r shift left logical word *) | Paddl (**r add long *) + | Paddxl (shift : shift1_4) (**r add shift long *) | Psubl (**r sub long *) + | Prevsubxl (shift : shift1_4) (**r sub shift long *) | Pandl (**r and long *) | Pnandl (**r nand long *) | Porl (**r or long *) @@ -466,12 +459,19 @@ Inductive arith_name_rrr : Type := | Pfsbfw (**r float sub word *) | Pfmuld (**r float multiply double *) | Pfmulw (**r float multiply word *) + | Pfmind (**r float min double *) + | Pfminw (**r float min word *) + | Pfmaxd (**r float max double *) + | Pfmaxw (**r float max word *) . Inductive arith_name_rri32 : Type := | Pcompiw (it: itest) (**r comparison imm word *) | Paddiw (**r add imm word *) + | Paddxiw (shift : shift1_4) + | Prevsubiw (**r add imm word *) + | Prevsubxiw (shift : shift1_4) | Pmuliw (**r add imm word *) | Pandiw (**r and imm word *) | Pnandiw (**r nand imm word *) @@ -495,6 +495,9 @@ Inductive arith_name_rri32 : Type := Inductive arith_name_rri64 : Type := | Pcompil (it: itest) (**r comparison imm long *) | Paddil (**r add immediate long *) + | Paddxil (shift : shift1_4) + | Prevsubil + | Prevsubxil (shift : shift1_4) | Pmulil (**r mul immediate long *) | Pandil (**r and immediate long *) | Pnandil (**r nand immediate long *) @@ -509,16 +512,26 @@ Inductive arith_name_rri64 : Type := Inductive arith_name_arrr : Type := | Pmaddw (**r multiply add word *) | Pmaddl (**r multiply add long *) + | Pmsubw (**r multiply subtract word *) + | Pmsubl (**r multiply subtract long *) | Pcmove (bt: btest) (**r conditional move *) | Pcmoveu (bt: btest) (**r conditional move, test on unsigned semantics *) + | Pfmaddfw (**r float fused multiply add word *) + | Pfmaddfl (**r float fused multiply add long *) + | Pfmsubfw (**r float fused multiply subtract word *) + | Pfmsubfl (**r float fused multiply subtract long *) . Inductive arith_name_arri32 : Type := | Pmaddiw (**r multiply add word *) + | Pcmoveiw (bt: btest) + | Pcmoveuiw (bt: btest) . Inductive arith_name_arri64 : Type := | Pmaddil (**r multiply add long *) + | Pcmoveil (bt: btest) + | Pcmoveuil (bt: btest) . Inductive arith_name_arr : Type := @@ -542,6 +555,8 @@ Inductive ar_instruction : Type := | PArithARRI64 (i: arith_name_arri64) (rd rs: ireg) (imm: int64) . +Module PArithCoercions. + Coercion PArithR: arith_name_r >-> Funclass. Coercion PArithRR: arith_name_rr >-> Funclass. Coercion PArithRI32: arith_name_ri32 >-> Funclass. @@ -556,6 +571,8 @@ Coercion PArithARR: arith_name_arr >-> Funclass. Coercion PArithARRI32: arith_name_arri32 >-> Funclass. Coercion PArithARRI64: arith_name_arri64 >-> Funclass. +End PArithCoercions. + Inductive basic : Type := | PArith (i: ar_instruction) | PLoad (i: ld_instruction) @@ -901,10 +918,6 @@ Definition compare_int (t: itest) (v1 v2: val): val := | ITgeu => Val_cmpu Cge v1 v2 | ITleu => Val_cmpu Cle v1 v2 | ITgtu => Val_cmpu Cgt v1 v2 - | ITall - | ITnall - | ITany - | ITnone => Vundef end. Definition compare_long (t: itest) (v1 v2: val): val := @@ -921,10 +934,6 @@ Definition compare_long (t: itest) (v1 v2: val): val := | ITgeu => Some (Val_cmplu Cge v1 v2) | ITleu => Some (Val_cmplu Cle v1 v2) | ITgtu => Some (Val_cmplu Cgt v1 v2) - | ITall - | ITnall - | ITany - | ITnone => Some Vundef end in match res with | Some v => v @@ -976,6 +985,7 @@ Definition arith_eval_rr n v := | Pfnegw => Val.negfs v | Pfabsd => Val.absf v | Pfabsw => Val.absfs v + | Pfinvw => ExtValues.invfs v | Pfnarrowdw => Val.singleoffloat v | Pfwidenlwd => Val.floatofsingle v | Pfloatwrnsz => match Val.singleofint v with Some f => f | _ => Vundef end @@ -1055,12 +1065,24 @@ Definition arith_eval_rrr n v1 v2 := | Pfsbfw => Val.subfs v1 v2 | Pfmuld => Val.mulf v1 v2 | Pfmulw => Val.mulfs v1 v2 + + | Pfmind => ExtValues.minf v1 v2 + | Pfminw => ExtValues.minfs v1 v2 + | Pfmaxd => ExtValues.maxf v1 v2 + | Pfmaxw => ExtValues.maxfs v1 v2 + + | Paddxw shift => ExtValues.addx (int_of_shift1_4 shift) v1 v2 + | Paddxl shift => ExtValues.addxl (int_of_shift1_4 shift) v1 v2 + + | Prevsubxw shift => ExtValues.revsubx (int_of_shift1_4 shift) v1 v2 + | Prevsubxl shift => ExtValues.revsubxl (int_of_shift1_4 shift) v1 v2 end. Definition arith_eval_rri32 n v i := match n with | Pcompiw c => compare_int c v (Vint i) | Paddiw => Val.add v (Vint i) + | Prevsubiw => Val.sub (Vint i) v | Pmuliw => Val.mul v (Vint i) | Pandiw => Val.and v (Vint i) | Pnandiw => Val.notint (Val.and v (Vint i)) @@ -1079,12 +1101,15 @@ Definition arith_eval_rri32 n v i := | Psrxil => ExtValues.val_shrxl v (Vint i) | Psrlil => Val.shrlu v (Vint i) | Psrail => Val.shrl v (Vint i) + | Paddxiw shift => ExtValues.addx (int_of_shift1_4 shift) v (Vint i) + | Prevsubxiw shift => ExtValues.revsubx (int_of_shift1_4 shift) v (Vint i) end. Definition arith_eval_rri64 n v i := match n with | Pcompil c => compare_long c v (Vlong i) | Paddil => Val.addl v (Vlong i) + | Prevsubil => Val.subl (Vlong i) v | Pmulil => Val.mull v (Vlong i) | Pandil => Val.andl v (Vlong i) | Pnandil => Val.notl (Val.andl v (Vlong i)) @@ -1094,44 +1119,56 @@ Definition arith_eval_rri64 n v i := | Pnxoril => Val.notl (Val.xorl v (Vlong i)) | Pandnil => Val.andl (Val.notl v) (Vlong i) | Pornil => Val.orl (Val.notl v) (Vlong i) + | Paddxil shift => ExtValues.addxl (int_of_shift1_4 shift) v (Vlong i) + | Prevsubxil shift => ExtValues.revsubxl (int_of_shift1_4 shift) v (Vlong i) + end. + +Definition cmove bt v1 v2 v3 := + match cmp_for_btest bt with + | (Some c, Int) => + match Val.cmp_bool c v2 (Vint Int.zero) with + | None => Vundef + | Some true => v3 + | Some false => v1 + end + | (Some c, Long) => + match Val.cmpl_bool c v2 (Vlong Int64.zero) with + | None => Vundef + | Some true => v3 + | Some false => v1 + end + | (None, _) => Vundef + end. + +Definition cmoveu bt v1 v2 v3 := + match cmpu_for_btest bt with + | (Some c, Int) => + match Val_cmpu_bool c v2 (Vint Int.zero) with + | None => Vundef + | Some true => v3 + | Some false => v1 + end + | (Some c, Long) => + match Val_cmplu_bool c v2 (Vlong Int64.zero) with + | None => Vundef + | Some true => v3 + | Some false => v1 + end + | (None, _) => Vundef end. Definition arith_eval_arrr n v1 v2 v3 := match n with | Pmaddw => Val.add v1 (Val.mul v2 v3) | Pmaddl => Val.addl v1 (Val.mull v2 v3) - | Pcmove bt => - match cmp_for_btest bt with - | (Some c, Int) => - match Val.cmp_bool c v2 (Vint Int.zero) with - | None => Vundef - | Some true => v3 - | Some false => v1 - end - | (Some c, Long) => - match Val.cmpl_bool c v2 (Vlong Int64.zero) with - | None => Vundef - | Some true => v3 - | Some false => v1 - end - | (None, _) => Vundef - end - | Pcmoveu bt => - match cmpu_for_btest bt with - | (Some c, Int) => - match Val_cmpu_bool c v2 (Vint Int.zero) with - | None => Vundef - | Some true => v3 - | Some false => v1 - end - | (Some c, Long) => - match Val_cmplu_bool c v2 (Vlong Int64.zero) with - | None => Vundef - | Some true => v3 - | Some false => v1 - end - | (None, _) => Vundef - end + | Pmsubw => Val.sub v1 (Val.mul v2 v3) + | Pmsubl => Val.subl v1 (Val.mull v2 v3) + | Pcmove bt => cmove bt v1 v2 v3 + | Pcmoveu bt => cmoveu bt v1 v2 v3 + | Pfmaddfw => ExtValues.fmaddfs v1 v2 v3 + | Pfmaddfl => ExtValues.fmaddf v1 v2 v3 + | Pfmsubfw => ExtValues.fmsubfs v1 v2 v3 + | Pfmsubfl => ExtValues.fmsubf v1 v2 v3 end. Definition arith_eval_arr n v1 v2 := @@ -1143,11 +1180,15 @@ Definition arith_eval_arr n v1 v2 := Definition arith_eval_arri32 n v1 v2 v3 := match n with | Pmaddiw => Val.add v1 (Val.mul v2 (Vint v3)) + | Pcmoveiw bt => cmove bt v1 v2 (Vint v3) + | Pcmoveuiw bt => cmoveu bt v1 v2 (Vint v3) end. Definition arith_eval_arri64 n v1 v2 v3 := match n with | Pmaddil => Val.addl v1 (Val.mull v2 (Vlong v3)) + | Pcmoveil bt => cmove bt v1 v2 (Vlong v3) + | Pcmoveuil bt => cmoveu bt v1 v2 (Vlong v3) end. Definition parexec_arith_instr (ai: ar_instruction) (rsr rsw: regset): regset := @@ -1175,10 +1216,16 @@ Definition eval_offset (ofs: offset) : res ptrofs := OK ofs. (** * load/store *) -Definition parexec_load_offset (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a: ireg) (ofs: offset) := +Definition parexec_incorrect_load trap chunk d rsw mw := + match trap with + | TRAP => Stuck + | NOTRAP => Next (rsw#d <- (concrete_default_notrap_load_value chunk)) mw + end. + +Definition parexec_load_offset (trap: trapping_mode) (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a: ireg) (ofs: offset) := match (eval_offset ofs) with | OK ptr => match Mem.loadv chunk mr (Val.offset_ptr (rsr a) ptr) with - | None => Stuck + | None => parexec_incorrect_load trap chunk d rsw mw | Some v => Next (rsw#d <- v) mw end | _ => Stuck @@ -1223,15 +1270,15 @@ Definition parexec_load_o_offset (rsr rsw: regset) (mr mw: mem) (d : gpreg_o) (a end end. -Definition parexec_load_reg (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a ro: ireg) := +Definition parexec_load_reg (trap: trapping_mode) (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a ro: ireg) := match Mem.loadv chunk mr (Val.addl (rsr a) (rsr ro)) with - | None => Stuck + | None => parexec_incorrect_load trap chunk d rsw mw | Some v => Next (rsw#d <- v) mw end. -Definition parexec_load_regxs (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a ro: ireg) := +Definition parexec_load_regxs (trap: trapping_mode) (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a ro: ireg) := match Mem.loadv chunk mr (Val.addl (rsr a) (Val.shll (rsr ro) (scale_of_chunk chunk))) with - | None => Stuck + | None => parexec_incorrect_load trap chunk d rsw mw | Some v => Next (rsw#d <- v) mw end. @@ -1244,7 +1291,8 @@ Definition parexec_store_offset (chunk: memory_chunk) (rsr rsw: regset) (mr mw: | _ => Stuck end. -Definition parexec_store_reg (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (s a ro: ireg) := +Definition parexec_store_reg + (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (s a ro: ireg) := match Mem.storev chunk mr (Val.addl (rsr a) (rsr ro)) (rsr s) with | None => Stuck | Some m' => Next rsw m' @@ -1302,7 +1350,7 @@ Definition load_chunk n := | Pfls => Mfloat32 | Pfld => Mfloat64 end. - + Definition store_chunk n := match n with | Psb => Mint8unsigned @@ -1317,16 +1365,16 @@ Definition store_chunk n := (** * basic instructions *) -Definition parexec_basic_instr (bi: basic) (rsr rsw: regset) (mr mw: mem) := +Definition bstep (bi: basic) (rsr rsw: regset) (mr mw: mem) := match bi with | PArith ai => Next (parexec_arith_instr ai rsr rsw) mw - | PLoadRRO n d a ofs => parexec_load_offset (load_chunk n) rsr rsw mr mw d a ofs - | PLoadRRR n d a ro => parexec_load_reg (load_chunk n) rsr rsw mr mw d a ro - | PLoadRRRXS n d a ro => parexec_load_regxs (load_chunk n) rsr rsw mr mw d a ro - | PLoadQRRO d a ofs => + | PLoad (PLoadRRO trap n d a ofs) => parexec_load_offset trap (load_chunk n) rsr rsw mr mw d a ofs + | PLoad (PLoadRRR trap n d a ro) => parexec_load_reg trap (load_chunk n) rsr rsw mr mw d a ro + | PLoad (PLoadRRRXS trap n d a ro) => parexec_load_regxs trap (load_chunk n) rsr rsw mr mw d a ro + | PLoad (PLoadQRRO d a ofs) => parexec_load_q_offset rsr rsw mr mw d a ofs - | PLoadORRO d a ofs => + | PLoad (PLoadORRO d a ofs) => parexec_load_o_offset rsr rsw mr mw d a ofs | PStoreRRO n s a ofs => parexec_store_offset (store_chunk n) rsr rsw mr mw s a ofs @@ -1376,7 +1424,7 @@ Fixpoint parexec_wio_body (body: list basic) (rsr rsw: regset) (mr mw: mem) := match body with | nil => Next rsw mw | bi::body' => - match parexec_basic_instr bi rsr rsw mr mw with + match bstep bi rsr rsw mr mw with | Next rsw mw => parexec_wio_body body' rsr rsw mr mw | Stuck => Stuck end @@ -1512,19 +1560,19 @@ Definition incrPC size_b (rs: regset) := rs#PC <- (Val.offset_ptr rs#PC size_b). (** parallel execution of the exit instruction of a bundle *) -Definition parexec_exit (f: function) ext size_b (rsr rsw: regset) (mw: mem) +Definition estep (f: function) ext size_b (rsr rsw: regset) (mw: mem) := parexec_control f ext (incrPC size_b rsr) rsw mw. -Definition parexec_wio_bblock_aux f bdy ext size_b (rsr rsw: regset) (mr mw: mem): outcome := - match parexec_wio_body bdy rsr rsw mr mw with - | Next rsw mw => parexec_exit f ext size_b rsr rsw mw +Definition parexec_wio f bdy ext size_b (rs: regset) (m: mem): outcome := + match parexec_wio_body bdy rs rs m m with + | Next rsw mw => estep f ext size_b rs rsw mw | Stuck => Stuck end. (** non-deterministic (out-of-order writes) parallel execution of bundles *) Definition parexec_bblock (f: function) (bundle: bblock) (rs: regset) (m: mem) (o: outcome): Prop := exists bdy1 bdy2, Permutation (bdy1++bdy2) (body bundle) /\ - o=match parexec_wio_bblock_aux f bdy1 (exit bundle) (Ptrofs.repr (size bundle)) rs rs m m with + o=match parexec_wio f bdy1 (exit bundle) (Ptrofs.repr (size bundle)) rs m with | Next rsw mw => parexec_wio_body bdy2 rs rsw m mw | Stuck => Stuck end. @@ -1651,7 +1699,7 @@ Inductive step: state -> trace -> state -> Prop := (** parallel in-order writes execution of bundles *) Definition parexec_wio_bblock (f: function) (b: bblock) (rs: regset) (m: mem): outcome := - parexec_wio_bblock_aux f (body b) (exit b) (Ptrofs.repr (size b)) rs rs m m. + parexec_wio f (body b) (exit b) (Ptrofs.repr (size b)) rs m. Lemma parexec_bblock_write_in_order f b rs m: @@ -1661,11 +1709,11 @@ Proof. constructor 1. - rewrite app_nil_r; auto. - unfold parexec_wio_bblock. - destruct (parexec_wio_bblock_aux f _ _ _ _ _); simpl; auto. + destruct (parexec_wio f _ _ _); simpl; auto. Qed. -Local Hint Resolve parexec_bblock_write_in_order. +Local Hint Resolve parexec_bblock_write_in_order: core. Lemma det_parexec_write_in_order f b rs m rs' m': det_parexec f b rs m rs' m' -> parexec_wio_bblock f b rs m = Next rs' m'. @@ -1739,9 +1787,9 @@ Ltac Det_WIO X := - (* determ *) intros s t1 s1 t2 s2 H H0. inv H; Det_WIO X1; inv H0; Det_WIO X2; Equalities. + split. constructor. auto. - + unfold parexec_wio_bblock, parexec_wio_bblock_aux in X1. destruct (parexec_wio_body _ _ _ _ _ _); try discriminate. + + unfold parexec_wio_bblock, parexec_wio in X1. destruct (parexec_wio_body _ _ _ _ _ _); try discriminate. rewrite H8 in X1. discriminate. - + unfold parexec_wio_bblock, parexec_wio_bblock_aux in X2. destruct (parexec_wio_body _ _ _ _ _ _); try discriminate. + + unfold parexec_wio_bblock, parexec_wio in X2. destruct (parexec_wio_body _ _ _ _ _ _); try discriminate. rewrite H4 in X2. discriminate. + assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0. exploit external_call_determ. eexact H6. eexact H13. intros [A B]. diff --git a/mppa_k1c/Builtins1.v b/mppa_k1c/Builtins1.v new file mode 100644 index 00000000..3b5cd419 --- /dev/null +++ b/mppa_k1c/Builtins1.v @@ -0,0 +1,66 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, Collège de France and Inria Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Platform-specific built-in functions *) + +Require Import String Coqlib. +Require Import AST Integers Floats Values ExtFloats. +Require Import Builtins0. + +Inductive platform_builtin : Type := +| BI_fmin +| BI_fmax +| BI_fminf +| BI_fmaxf +| BI_fabsf +| BI_fma +| BI_fmaf. + +Local Open Scope string_scope. + +Definition platform_builtin_table : list (string * platform_builtin) := + ("__builtin_fmin", BI_fmin) + :: ("__builtin_fmax", BI_fmax) + :: ("__builtin_fminf", BI_fminf) + :: ("__builtin_fmaxf", BI_fmaxf) + :: ("__builtin_fabsf", BI_fabsf) + :: ("__builtin_fma", BI_fma) + :: ("__builtin_fmaf", BI_fmaf) + :: nil. + +Definition platform_builtin_sig (b: platform_builtin) : signature := + match b with + | BI_fmin | BI_fmax => + mksignature (Tfloat :: Tfloat :: nil) Tfloat cc_default + | BI_fminf | BI_fmaxf => + mksignature (Tsingle :: Tsingle :: nil) Tsingle cc_default + | BI_fabsf => + mksignature (Tsingle :: nil) Tsingle cc_default + | BI_fma => + mksignature (Tfloat :: Tfloat :: Tfloat :: nil) Tfloat cc_default + | BI_fmaf => + mksignature (Tsingle :: Tsingle :: Tsingle :: nil) Tsingle cc_default + end. + +Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (sig_res (platform_builtin_sig b)) := + match b with + | BI_fmin => mkbuiltin_n2t Tfloat Tfloat Tfloat ExtFloat.min + | BI_fmax => mkbuiltin_n2t Tfloat Tfloat Tfloat ExtFloat.max + | BI_fminf => mkbuiltin_n2t Tsingle Tsingle Tsingle ExtFloat32.min + | BI_fmaxf => mkbuiltin_n2t Tsingle Tsingle Tsingle ExtFloat32.max + | BI_fabsf => mkbuiltin_n1t Tsingle Tsingle Float32.abs + | BI_fma => mkbuiltin_n3t Tfloat Tfloat Tfloat Tfloat Float.fma + | BI_fmaf => mkbuiltin_n3t Tsingle Tsingle Tsingle Tsingle Float32.fma + end. diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index 2f80c90f..a91119b1 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -18,11 +18,11 @@ open C let builtins = { - Builtins.typedefs = [ + builtin_typedefs = [ "__builtin_va_list", TPtr(TVoid [], []) ]; (* The builtin list is inspired from the GCC file builtin_k1.h *) - Builtins.functions = [ (* Some builtins are commented out because their opcode is not present (yet?) *) + builtin_functions = [ (* Some builtins are commented out because their opcode is not present (yet?) *) (* BCU Instructions *) "__builtin_k1_await", (TVoid [], [], false); (* DONE *) "__builtin_k1_barrier", (TVoid [], [], false); (* DONE *) @@ -43,8 +43,8 @@ let builtins = { (* LSU Instructions *) (* acswapd and acswapw done using headers and assembly *) - "__builtin_k1_afaddd", (TInt(IULongLong, []), [TPtr(TVoid [], []); TInt(ILongLong, [])], false); - "__builtin_k1_afaddw", (TInt(IUInt, []), [TPtr(TVoid [], []); TInt(IInt, [])], false); +(* "__builtin_k1_afaddd", (TInt(IULongLong, []), [TPtr(TVoid [], []); TInt(ILongLong, [])], false); + "__builtin_k1_afaddw", (TInt(IUInt, []), [TPtr(TVoid [], []); TInt(IInt, [])], false); *) (* see #157 *) "__builtin_k1_alclrd", (TInt(IULongLong, []), [TPtr(TVoid [], [])], false); (* DONE *) "__builtin_k1_alclrw", (TInt(IUInt, []), [TPtr(TVoid [], [])], false); (* DONE *) "__builtin_k1_dinval", (TVoid [], [], false); (* DONE *) @@ -63,7 +63,6 @@ let builtins = { "__builtin_k1_lwzu", (TInt(IUInt, []), [TPtr(TVoid [], [])], false); (* ALU Instructions *) - "__builtin_clzll", (TInt(IULongLong, []), [TInt(IULongLong, [])], false); (* "__builtin_k1_addhp", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, [])], false); *) (* "__builtin_k1_adds", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, [])], false); *) (* "__builtin_k1_bwlu", (TInt(IUInt, []), @@ -74,8 +73,8 @@ let builtins = { (* "__builtin_k1_cbs", (TInt(IInt, []), [TInt(IUInt, [])], false); *) (* "__builtin_k1_cbsdl", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); *) (* "__builtin_k1_clz", (TInt(IInt, []), [TInt(IUInt, [])], false); *) - "__builtin_k1_clzw", (TInt(IInt, []), [TInt(IUInt, [])], false); - "__builtin_k1_clzd", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); + "__builtin_clzw", (TInt(IInt, []), [TInt(IUInt, [])], false); + "__builtin_clzll", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); (* "__builtin_k1_clzdl", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); *) (* "__builtin_k1_cmove", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, []); TInt(IInt, [])], false); *) (* "__builtin_k1_ctz", (TInt(IInt, []), [TInt(IUInt, [])], false); *) @@ -97,12 +96,8 @@ let builtins = { (* Synchronization *) (* "__builtin_fence", - (TVoid [], [], false); - (* Integer arithmetic *) - "__builtin_bswap64", - (TInt(IULongLong, []), - [TInt(IULongLong, [])], false); - (* Float arithmetic *) + (TVoid [], [], false); *) +(* (* Float arithmetic *) "__builtin_fmadd", (TFloat(FDouble, []), [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); @@ -114,14 +109,29 @@ let builtins = { [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); "__builtin_fnmsub", (TFloat(FDouble, []), - [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); + [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); *) + "__builtin_fabsf", + (TFloat(FFloat, []), + [TFloat(FFloat, [])], false); "__builtin_fmax", (TFloat(FDouble, []), [TFloat(FDouble, []); TFloat(FDouble, [])], false); "__builtin_fmin", (TFloat(FDouble, []), [TFloat(FDouble, []); TFloat(FDouble, [])], false); -*)] + "__builtin_fmaxf", + (TFloat(FFloat, []), + [TFloat(FFloat, []); TFloat(FFloat, [])], false); + "__builtin_fminf", + (TFloat(FFloat, []), + [TFloat(FFloat, []); TFloat(FFloat, [])], false); + "__builtin_fma", + (TFloat(FDouble, []), + [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); + "__builtin_fmaf", + (TFloat(FFloat, []), + [TFloat(FFloat, []); TFloat(FFloat, []); TFloat(FFloat, [])], false); +] } let va_list_type = TPtr(TVoid [], []) (* to check! *) diff --git a/mppa_k1c/CSE2deps.v b/mppa_k1c/CSE2deps.v new file mode 100644 index 00000000..8ab9242a --- /dev/null +++ b/mppa_k1c/CSE2deps.v @@ -0,0 +1,20 @@ +Require Import BoolEqual Coqlib. +Require Import AST Integers Floats. +Require Import Values Memory Globalenvs Events. +Require Import Op. + + +Definition can_swap_accesses_ofs ofsr chunkr ofsw chunkw := + (0 <=? ofsw) && (ofsw <=? (Ptrofs.modulus - largest_size_chunk)) + && (0 <=? ofsr) && (ofsr <=? (Ptrofs.modulus - largest_size_chunk)) + && ((ofsw + size_chunk chunkw <=? ofsr) || + (ofsr + size_chunk chunkr <=? ofsw)). + +Definition may_overlap chunk addr args chunk' addr' args' := + match addr, addr', args, args' with + | (Aindexed ofs), (Aindexed ofs'), + (base :: nil), (base' :: nil) => + if peq base base' + then negb (can_swap_accesses_ofs (Ptrofs.unsigned ofs') chunk' (Ptrofs.unsigned ofs) chunk) + else true | _, _, _, _ => true + end. diff --git a/mppa_k1c/CSE2depsproof.v b/mppa_k1c/CSE2depsproof.v new file mode 100644 index 00000000..a3811e78 --- /dev/null +++ b/mppa_k1c/CSE2depsproof.v @@ -0,0 +1,127 @@ +Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Memory Registers Op RTL Maps. + +Require Import Globalenvs Values. +Require Import Linking Values Memory Globalenvs Events Smallstep. +Require Import Registers Op RTL. +Require Import CSE2 CSE2deps. +Require Import Lia. + +Lemma ptrofs_size : + Ptrofs.wordsize = (if Archi.ptr64 then 64 else 32)%nat. +Proof. + unfold Ptrofs.wordsize. + unfold Wordsize_Ptrofs.wordsize. + trivial. +Qed. + +Lemma ptrofs_modulus : + Ptrofs.modulus = if Archi.ptr64 then 18446744073709551616 else 4294967296. +Proof. + unfold Ptrofs.modulus. + rewrite ptrofs_size. + destruct Archi.ptr64; reflexivity. +Qed. + +Section SOUNDNESS. + Variable F V : Type. + Variable genv: Genv.t F V. + Variable sp : val. + +Section MEMORY_WRITE. + Variable m m2 : mem. + Variable chunkw chunkr : memory_chunk. + Variable base : val. + + Variable addrw addrr valw : val. + Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. + + Section INDEXED_AWAY. + Variable ofsw ofsr : ptrofs. + Hypothesis ADDRW : eval_addressing genv sp + (Aindexed ofsw) (base :: nil) = Some addrw. + Hypothesis ADDRR : eval_addressing genv sp + (Aindexed ofsr) (base :: nil) = Some addrr. + + Lemma load_store_away1 : + forall RANGEW : 0 <= Ptrofs.unsigned ofsw <= Ptrofs.modulus - largest_size_chunk, + forall RANGER : 0 <= Ptrofs.unsigned ofsr <= Ptrofs.modulus - largest_size_chunk, + forall SWAPPABLE : Ptrofs.unsigned ofsw + size_chunk chunkw <= Ptrofs.unsigned ofsr + \/ Ptrofs.unsigned ofsr + size_chunk chunkr <= Ptrofs.unsigned ofsw, + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. + + Proof. + intros. + + pose proof (max_size_chunk chunkr) as size_chunkr_bounded. + pose proof (max_size_chunk chunkw) as size_chunkw_bounded. + unfold largest_size_chunk in *. + + rewrite ptrofs_modulus in *. + simpl in *. + inv ADDRR. + inv ADDRW. + destruct base; try discriminate. + eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b). + exact STORE. + right. + + all: try (destruct (Ptrofs.unsigned_add_either i ofsr) as [OFSR | OFSR]; + rewrite OFSR). + all: try (destruct (Ptrofs.unsigned_add_either i ofsw) as [OFSW | OFSW]; + rewrite OFSW). + all: try rewrite ptrofs_modulus in *. + all: destruct Archi.ptr64. + + all: intuition lia. + Qed. + + Theorem load_store_away : + can_swap_accesses_ofs (Ptrofs.unsigned ofsr) chunkr (Ptrofs.unsigned ofsw) chunkw = true -> + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. + Proof. + intro SWAP. + unfold can_swap_accesses_ofs in SWAP. + repeat rewrite andb_true_iff in SWAP. + repeat rewrite orb_true_iff in SWAP. + repeat rewrite Z.leb_le in SWAP. + apply load_store_away1. + all: tauto. + Qed. + End INDEXED_AWAY. +End MEMORY_WRITE. +End SOUNDNESS. + + +Section SOUNDNESS. + Variable F V : Type. + Variable genv: Genv.t F V. + Variable sp : val. + +Lemma may_overlap_sound: + forall m m' : mem, + forall chunk addr args chunk' addr' args' v a a' rs, + (eval_addressing genv sp addr (rs ## args)) = Some a -> + (eval_addressing genv sp addr' (rs ## args')) = Some a' -> + (may_overlap chunk addr args chunk' addr' args') = false -> + (Mem.storev chunk m a v) = Some m' -> + (Mem.loadv chunk' m' a') = (Mem.loadv chunk' m a'). +Proof. + intros until rs. + intros ADDR ADDR' OVERLAP STORE. + destruct addr; destruct addr'; try discriminate. + { (* Aindexed / Aindexed *) + destruct args as [ | base [ | ]]. 1,3: discriminate. + destruct args' as [ | base' [ | ]]. 1,3: discriminate. + simpl in OVERLAP. + destruct (peq base base'). 2: discriminate. + subst base'. + destruct (can_swap_accesses_ofs (Ptrofs.unsigned i0) chunk' (Ptrofs.unsigned i) chunk) eqn:SWAP. + 2: discriminate. + simpl in *. + eapply load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption. + } +Qed. + +End SOUNDNESS. diff --git a/mppa_k1c/ConstpropOp.vp b/mppa_k1c/ConstpropOp.vp index b5128357..7ee3dfe8 100644 --- a/mppa_k1c/ConstpropOp.vp +++ b/mppa_k1c/ConstpropOp.vp @@ -298,7 +298,7 @@ Nondetfunction addr_strength_reduction (addr: addressing) (args: list reg) (vl: list aval) := match addr, args, vl with | Aindexed n, r1 :: nil, Ptr(Gl symb n1) :: nil => - if (orb (Archi.pic_code tt) (negb (Compopts.optim_fglobaladdrtmp tt))) + if (orb (Archi.pic_code tt) (negb (Compopts.optim_globaladdrtmp tt))) then (addr, args) else (Aglobal symb (Ptrofs.add n1 n), nil) | Aindexed n, r1 :: nil, Ptr(Stk n1) :: nil => diff --git a/mppa_k1c/Conventions1.v b/mppa_k1c/Conventions1.v index d41f1095..48346a6d 100644 --- a/mppa_k1c/Conventions1.v +++ b/mppa_k1c/Conventions1.v @@ -90,12 +90,17 @@ Definition is_float_reg (r: mreg) := false. returned value. We treat a function without result as a function with one integer result. *) + Definition loc_result (s: signature) : rpair mreg := - match s.(sig_res) with - | None => One R0 - | Some (Tint | Tany32) => One R0 - | Some (Tfloat | Tsingle | Tany64) => One R0 - | Some Tlong => if Archi.ptr64 then One R0 else One R0 + match s.(sig_res) with + | Tvoid => One R0 + | Tint8signed => One R0 + | Tint8unsigned => One R0 + | Tint16signed => One R0 + | Tint16unsigned => One R0 + | Tint | Tany32 => One R0 + | Tfloat | Tsingle | Tany64 => One R0 + | Tlong => if Archi.ptr64 then One R0 else One R0 end. (** The result registers have types compatible with that given in the signature. *) @@ -104,8 +109,8 @@ 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, mreg_type; - destruct (sig_res sig) as [[]|]; auto; destruct Archi.ptr64; auto. + intros. unfold proj_sig_res, loc_result, mreg_type. + destruct (sig_res sig); try destruct Archi.ptr64; simpl; trivial; destruct t; trivial. Qed. (** The result locations are caller-save registers *) @@ -115,7 +120,7 @@ Lemma loc_result_caller_save: forall_rpair (fun r => is_callee_save r = false) (loc_result s). Proof. intros. unfold loc_result, is_callee_save; - destruct (sig_res s) as [[]|]; simpl; auto; destruct Archi.ptr64; simpl; auto. + destruct (sig_res s); simpl; auto; try destruct Archi.ptr64; simpl; auto; try destruct t; simpl; auto. Qed. (** If the result is in a pair of registers, those registers are distinct and have type [Tint] at least. *) @@ -125,14 +130,15 @@ Lemma loc_result_pair: match loc_result sg with | One _ => True | Twolong r1 r2 => - r1 <> r2 /\ sg.(sig_res) = Some Tlong + r1 <> r2 /\ proj_sig_res sg = Tlong /\ subtype Tint (mreg_type r1) = true /\ subtype Tint (mreg_type r2) = true /\ Archi.ptr64 = false end. Proof. intros. - unfold loc_result; destruct (sig_res sg) as [[]|]; auto. - unfold mreg_type; destruct Archi.ptr64; auto. + unfold loc_result; destruct (sig_res sg); auto; + unfold mreg_type; try destruct Archi.ptr64; auto; + destruct t; auto. Qed. (** The location of the result depends only on the result part of the signature *) @@ -409,3 +415,6 @@ Lemma loc_arguments_main: Proof. reflexivity. Qed. + + +Definition return_value_needs_normalization (t: rettype) : bool := false. diff --git a/mppa_k1c/DuplicateOpcodeHeuristic.ml b/mppa_k1c/DuplicateOpcodeHeuristic.ml new file mode 100644 index 00000000..2ec314c1 --- /dev/null +++ b/mppa_k1c/DuplicateOpcodeHeuristic.ml @@ -0,0 +1,27 @@ +(* open Camlcoq *) +open Op +open Integers + +let opcode_heuristic code cond ifso ifnot is_loop_header = + match cond with + | Ccompimm (c, n) | Ccompuimm (c, n) -> if n == Integers.Int.zero then (match c with + | Clt | Cle -> Some false + | Cgt | Cge -> Some true + | _ -> None + ) else None + | Ccomplimm (c, n) | Ccompluimm (c, n) -> if n == Integers.Int64.zero then (match c with + | Clt | Cle -> Some false + | Cgt | Cge -> Some true + | _ -> None + ) else None + | Ccompf c | Ccompfs c -> (match c with + | Ceq -> Some false + | Cne -> Some true + | _ -> None + ) + | Cnotcompf c | Cnotcompfs c -> (match c with + | Ceq -> Some true + | Cne -> Some false + | _ -> None + ) + | _ -> None diff --git a/mppa_k1c/ExtFloats.v b/mppa_k1c/ExtFloats.v new file mode 100644 index 00000000..d9b9d3a6 --- /dev/null +++ b/mppa_k1c/ExtFloats.v @@ -0,0 +1,39 @@ +Require Import Floats Integers ZArith. + +Module ExtFloat. +(** TODO check with the actual K1c; + this is what happens on x86 and may be inappropriate. *) + +Definition min (x : float) (y : float) : float := + match Float.compare x y with + | Some Eq | Some Lt => x + | Some Gt | None => y + end. + +Definition max (x : float) (y : float) : float := + match Float.compare x y with + | Some Eq | Some Gt => x + | Some Lt | None => y + end. +End ExtFloat. + +Module ExtFloat32. +(** TODO check with the actual K1c *) + +Definition min (x : float32) (y : float32) : float32 := + match Float32.compare x y with + | Some Eq | Some Lt => x + | Some Gt | None => y + end. + +Definition max (x : float32) (y : float32) : float32 := + match Float32.compare x y with + | Some Eq | Some Gt => x + | Some Lt | None => y + end. + +Definition one := Float32.of_int (Int.repr (1%Z)). +Definition inv (x : float32) : float32 := + Float32.div one x. + +End ExtFloat32. diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 980e18f8..5a890f3c 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -1,6 +1,61 @@ Require Import Coqlib. Require Import Integers. Require Import Values. +Require Import Floats ExtFloats. + +Open Scope Z_scope. + +Definition abs_diff (x y : Z) := Z.abs (x - y). +Definition abs_diff2 (x y : Z) := + if x <=? y then y - x else x - y. +Lemma abs_diff2_correct : + forall x y : Z, (abs_diff x y) = (abs_diff2 x y). +Proof. + intros. + unfold abs_diff, abs_diff2. + unfold Z.leb. + pose proof (Z.compare_spec x y) as Hspec. + inv Hspec. + - rewrite Z.abs_eq; omega. + - rewrite Z.abs_neq; omega. + - rewrite Z.abs_eq; omega. +Qed. + +Inductive shift1_4 : Type := +| SHIFT1 | SHIFT2 | SHIFT3 | SHIFT4. + +Definition z_of_shift1_4 (x : shift1_4) := + match x with + | SHIFT1 => 1 + | SHIFT2 => 2 + | SHIFT3 => 3 + | SHIFT4 => 4 + end. + +Definition shift1_4_of_z (x : Z) := + if Z.eq_dec x 1 then Some SHIFT1 + else if Z.eq_dec x 2 then Some SHIFT2 + else if Z.eq_dec x 3 then Some SHIFT3 + else if Z.eq_dec x 4 then Some SHIFT4 + else None. + +Lemma shift1_4_of_z_correct : + forall z, + match shift1_4_of_z z with + | Some x => z_of_shift1_4 x = z + | None => True + end. +Proof. + intro. unfold shift1_4_of_z. + destruct (Z.eq_dec _ _); simpl; try congruence. + destruct (Z.eq_dec _ _); simpl; try congruence. + destruct (Z.eq_dec _ _); simpl; try congruence. + destruct (Z.eq_dec _ _); simpl; try congruence. + trivial. +Qed. + +Definition int_of_shift1_4 (x : shift1_4) := + Int.repr (z_of_shift1_4 x). Definition is_bitfield stop start := (Z.leb start stop) @@ -251,10 +306,10 @@ Proof. intros. apply Int.eqm_samerepr. unfold Int.eqm. - unfold Int.eqmod. + unfold Zbits.eqmod. pose proof (Int64.eqm_unsigned_repr x) as H64. unfold Int64.eqm in H64. - unfold Int64.eqmod in H64. + unfold Zbits.eqmod in H64. destruct H64 as [k64 H64]. change Int64.modulus with 18446744073709551616 in *. change Int.modulus with 4294967296. @@ -331,7 +386,7 @@ Proof. apply Int.eqm_samerepr. unfold Int.eqm. change (Int64.unsigned (Int64.repr (-2147483648))) with 18446744071562067968. - unfold Int.eqmod. + unfold Zbits.eqmod. change Int.modulus with 4294967296. exists (-4294967296). compute. @@ -388,7 +443,7 @@ Qed. (* Lemma signed_0_eqb : forall x, (Z.eqb (Int.signed x) 0) = Int.eq x Int.zero. -Admitted. +Qed. *) Lemma Z_quot_le: forall a b, @@ -577,3 +632,109 @@ Proof. } } Qed. + +Lemma sub_add_neg : + forall x y, Val.sub x y = Val.add x (Val.neg y). +Proof. + destruct x; destruct y; simpl; trivial. + f_equal. + apply Int.sub_add_opp. +Qed. + +Lemma neg_mul_distr_r : + forall x y, Val.neg (Val.mul x y) = Val.mul x (Val.neg y). +Proof. + destruct x; destruct y; simpl; trivial. + f_equal. + apply Int.neg_mul_distr_r. +Qed. + +(* pointer diff +Lemma sub_addl_negl : + forall x y, Val.subl x y = Val.addl x (Val.negl y). +Proof. + destruct x; destruct y; simpl; trivial. + + f_equal. apply Int64.sub_add_opp. + + destruct (Archi.ptr64) eqn:ARCHI64; trivial. + f_equal. rewrite Ptrofs.sub_add_opp. + pose (Ptrofs.agree64_neg ARCHI64 (Ptrofs.of_int64 i0) i0) as Hagree. + unfold Ptrofs.agree64 in Hagree. + unfold Ptrofs.add. + f_equal. f_equal. + rewrite Hagree. + pose (Ptrofs.agree64_of_int ARCHI64 (Int64.neg i0)) as Hagree2. + rewrite Hagree2. + reflexivity. + exact (Ptrofs.agree64_of_int ARCHI64 i0). + + destruct (Archi.ptr64) eqn:ARCHI64; simpl; trivial. + destruct (eq_block _ _); simpl; trivial. +Qed. + *) + +Lemma negl_mull_distr_r : + forall x y, Val.negl (Val.mull x y) = Val.mull x (Val.negl y). +Proof. + destruct x; destruct y; simpl; trivial. + f_equal. + apply Int64.neg_mul_distr_r. +Qed. + +Definition addx sh v1 v2 := + Val.add v2 (Val.shl v1 (Vint sh)). + +Definition addxl sh v1 v2 := + Val.addl v2 (Val.shll v1 (Vint sh)). + +Definition revsubx sh v1 v2 := + Val.sub v2 (Val.shl v1 (Vint sh)). + +Definition revsubxl sh v1 v2 := + Val.subl v2 (Val.shll v1 (Vint sh)). + +Definition minf v1 v2 := + match v1, v2 with + | (Vfloat f1), (Vfloat f2) => Vfloat (ExtFloat.min f1 f2) + | _, _ => Vundef + end. + +Definition maxf v1 v2 := + match v1, v2 with + | (Vfloat f1), (Vfloat f2) => Vfloat (ExtFloat.max f1 f2) + | _, _ => Vundef + end. + +Definition minfs v1 v2 := + match v1, v2 with + | (Vsingle f1), (Vsingle f2) => Vsingle (ExtFloat32.min f1 f2) + | _, _ => Vundef + end. + +Definition maxfs v1 v2 := + match v1, v2 with + | (Vsingle f1), (Vsingle f2) => Vsingle (ExtFloat32.max f1 f2) + | _, _ => Vundef + end. + +Definition invfs v1 := + match v1 with + | (Vsingle f1) => Vsingle (ExtFloat32.inv f1) + | _ => Vundef + end. + +Definition triple_op_float f v1 v2 v3 := + match v1, v2, v3 with + | (Vfloat f1), (Vfloat f2), (Vfloat f3) => Vfloat (f f1 f2 f3) + | _, _, _ => Vundef + end. + +Definition triple_op_single f v1 v2 v3 := + match v1, v2, v3 with + | (Vsingle f1), (Vsingle f2), (Vsingle f3) => Vsingle (f f1 f2 f3) + | _, _, _ => Vundef + end. + +Definition fmaddf := triple_op_float (fun f1 f2 f3 => Float.fma f2 f3 f1). +Definition fmaddfs := triple_op_single (fun f1 f2 f3 => Float32.fma f2 f3 f1). + +Definition fmsubf := triple_op_float (fun f1 f2 f3 => Float.fma (Float.neg f2) f3 f1). +Definition fmsubfs := triple_op_single (fun f1 f2 f3 => Float32.fma (Float32.neg f2) f3 f1). diff --git a/mppa_k1c/InstructionScheduler.ml b/mppa_k1c/InstructionScheduler.ml index 1fa55c9b..9d3503e2 100644 --- a/mppa_k1c/InstructionScheduler.ml +++ b/mppa_k1c/InstructionScheduler.ml @@ -307,8 +307,8 @@ let priority_list_scheduler (order : list_scheduler_order) let list_scheduler = priority_list_scheduler CRITICAL_PATH_ORDER;; -(** FIXME - warning fix *) -let _ = priority_list_scheduler INSTRUCTION_ORDER;; +(* dummy code for placating ocaml's warnings *) +let _ = fun x -> priority_list_scheduler INSTRUCTION_ORDER x;; type bundle = int list;; @@ -367,7 +367,7 @@ let bundles_to_schedule problem bundles : solution = let greedy_scheduler (problem : problem) : solution option = let bundles = make_bundles problem 0 in Some (bundles_to_schedule problem bundles);; - + (* alternate implementation let swap_array_elements a i j = let x = a.(i) in @@ -389,32 +389,36 @@ let array_reverse a = a';; *) +(* unneeded let array_reverse a = let n=Array.length a in Array.init n (fun i -> a.(n-1-i));; + *) let reverse_constraint nr_instructions ctr = - if ctr.instr_to < nr_instructions - then Some - { instr_to = nr_instructions -1 -ctr.instr_from; - instr_from = nr_instructions -1 - ctr.instr_to; - latency = ctr.latency } - else None;; + { instr_to = nr_instructions -ctr.instr_from; + instr_from = nr_instructions - ctr.instr_to; + latency = ctr.latency };; +(* unneeded let rec list_map_filter f = function | [] -> [] | h::t -> (match f h with | None -> list_map_filter f t | Some x -> x :: (list_map_filter f t));; + *) let reverse_problem problem = let nr_instructions = get_nr_instructions problem in { max_latency = problem.max_latency; resource_bounds = problem.resource_bounds; - instruction_usages = array_reverse problem.instruction_usages; - latency_constraints = list_map_filter (reverse_constraint nr_instructions) + instruction_usages = Array.init (nr_instructions + 1) + (fun i -> + if i=0 + then Array.map (fun _ -> 0) problem.resource_bounds else problem.instruction_usages.(nr_instructions - i)); + latency_constraints = List.map (reverse_constraint nr_instructions) problem.latency_constraints };; @@ -426,18 +430,28 @@ let max_scheduled_time solution = done; !time;; +(* +let recompute_makespan problem solution = + let n = (Array.length solution) - 1 and ms = ref 0 in + List.iter (fun cstr -> + if cstr.instr_to = n + then ms := max !ms (solution.(cstr.instr_from) + cstr.latency) + ) problem.latency_constraints; + !ms;; + *) + let schedule_reversed (scheduler : problem -> solution option) (problem : problem) = match scheduler (reverse_problem problem) with | None -> None | Some solution -> - let nr_instructions = get_nr_instructions problem - and maxi = max_scheduled_time solution in - Some (Array.init (Array.length solution) - (fun i -> - if i < nr_instructions - then maxi-solution.(nr_instructions-1-i) - else solution.(i)));; + let nr_instructions = get_nr_instructions problem in + let makespan = max_scheduled_time solution in + let ret = Array.init (nr_instructions + 1) + (fun i -> makespan-solution.(nr_instructions-i)) in + ret.(nr_instructions) <- max ((max_scheduled_time ret) + 1) + (ret.(nr_instructions)); + Some ret;; (** Schedule the problem using a greedy list scheduling algorithm, from the end. *) let reverse_list_scheduler = schedule_reversed list_scheduler;; @@ -1143,9 +1157,10 @@ let ilp_read_solution mapper channel = (if tnumber < 0 || tnumber >= (Array.length times) then failwith (Printf.sprintf "bad ilp output: not a correct variable number: %d (%d)" tnumber (Array.length times))); let value = - try rounded_int_of_string (String.sub line (space+1) ((String.length line)-space-1)) + let s = String.sub line (space+1) ((String.length line)-space-1) in + try rounded_int_of_string s with Failure _ -> - failwith "bad ilp output: not a time number" + failwith (Printf.sprintf "bad ilp output: not a time number (%s)" s) in (if value < 0 then failwith "bad ilp output: negative time"); @@ -1164,20 +1179,16 @@ let ilp_read_solution mapper channel = let ilp_solver = ref "ilp_solver" let problem_nr = ref 0 - -let do_with_resource destroy x f = - try - let r = f x in - destroy x; r - with exn -> destroy x; raise exn;; - + let ilp_scheduler pb_type problem = try let filename_in = Printf.sprintf "problem%05d.lp" !problem_nr and filename_out = Printf.sprintf "problem%05d.sol" !problem_nr in incr problem_nr; - let mapper = do_with_resource close_out (open_out filename_in) - (fun opb_problem -> ilp_print_problem opb_problem problem pb_type) in + let opb_problem = open_out filename_in in + let mapper = ilp_print_problem opb_problem problem pb_type in + close_out opb_problem; + begin match Unix.system (!ilp_solver ^ " " ^ filename_in ^ " " ^ filename_out) with | Unix.WEXITED 0 -> @@ -1190,20 +1201,33 @@ let ilp_scheduler pb_type problem = end with | Unschedulable -> None;; - + +let current_utime_all () = + let t = Unix.times() in + t.Unix.tms_cutime +. t.Unix.tms_utime;; + +let utime_all_fn fn arg = + let utime_start = current_utime_all () in + let output = fn arg in + let utime_end = current_utime_all () in + (output, utime_end -. utime_start);; + let cascaded_scheduler (problem : problem) = - match validated_scheduler list_scheduler problem with + let (some_initial_solution, list_scheduler_time) = + utime_all_fn (validated_scheduler list_scheduler) problem in + match some_initial_solution with | None -> None | Some initial_solution -> - let solution = reoptimizing_scheduler (validated_scheduler (ilp_scheduler SATISFIABILITY)) initial_solution problem in + let (solution, reoptimizing_time) = utime_all_fn (reoptimizing_scheduler (validated_scheduler (ilp_scheduler SATISFIABILITY)) initial_solution) problem in begin let latency2 = get_max_latency solution and latency1 = get_max_latency initial_solution in - if latency2 < latency1 - then Printf.printf "REOPTIMIZING SUCCEEDED %d < %d for %d instructions\n" latency2 latency1 (Array.length problem.instruction_usages) - else if latency2 = latency1 - then Printf.printf "%d unchanged\n" latency1 - else failwith "optimizing not optimizing" + Printf.printf "postpass %s: %d, %d, %d, %g, %g\n" + (if latency2 < latency1 then "REOPTIMIZED" else "unchanged") + (get_nr_instructions problem) + latency1 latency2 + list_scheduler_time reoptimizing_time; + flush stdout end; Some solution;; diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index cd8c6606..8098b5d1 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -213,8 +213,12 @@ Global Opaque Definition two_address_op (op: operation) : bool := match op with - | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ - | Oselect _ | Oselectl _ | Oselectf _ | Oselectfs _ + | Ofmaddf | Ofmaddfs + | Ofmsubf | Ofmsubfs + | Omadd | Omaddimm _ + | Omaddl | Omaddlimm _ + | Omsub | Omsubl + | Osel _ _ | Oselimm _ _ | Osellimm _ _ | Oinsf _ _ | Oinsfl _ _ => true | _ => false end. diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index c10f5c56..7111c48b 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -28,6 +28,7 @@ Definition op2 (nv: nval) := nv :: nv :: nil. Definition op3 (nv: nval) := nv :: nv :: nv :: nil. Definition needs_of_condition (cond: condition): list nval := nil. +Definition needs_of_condition0 (cond0: condition0): list nval := nil. Definition needs_of_operation (op: operation) (nv: nval): list nval := match op with @@ -42,8 +43,13 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Ocast16signed => op1 (sign_ext 16 nv) | Oadd => op2 (modarith nv) | Oaddimm n => op1 (modarith nv) + | Oaddx _ => op2 (default nv) + | Oaddximm _ _ => op1 (default nv) | Oneg => op1 (modarith nv) | Osub => op2 (default nv) + | Orevsubimm _ => op1 (default nv) + | Orevsubx _ => op2 (default nv) + | Orevsubximm _ _ => op1 (default nv) | Omul => op2 (modarith nv) | Omulimm _ => op1 (modarith nv) | Omulhs | Omulhu | Odiv | Odivu | Omod | Omodu => op2 (default nv) @@ -72,12 +78,18 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Oshrximm n => op1 (default nv) | Omadd => op3 (modarith nv) | Omaddimm n => op2 (modarith nv) + | Omsub => op3 (modarith nv) | Omakelong => op2 (default nv) | Olowlong | Ohighlong => op1 (default nv) | Ocast32signed => op1 (default nv) | Ocast32unsigned => op1 (default nv) | Oaddl => op2 (default nv) | Oaddlimm n => op1 (default nv) + | Oaddxl _ => op2 (default nv) + | Oaddxlimm _ _ => op1 (default nv) + | Orevsublimm _ => op1 (default nv) + | Orevsubxl _ => op2 (default nv) + | Orevsubxlimm _ _ => op1 (default nv) | Onegl => op1 (default nv) | Osubl => op2 (default nv) | Omull => op2 (default nv) @@ -107,19 +119,25 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Oshrxlimm n => op1 (default nv) | Omaddl => op3 (default nv) | Omaddlimm n => op2 (default nv) + | Omsubl => op3 (default nv) | Onegf | Oabsf => op1 (default nv) - | Oaddf | Osubf | Omulf | Odivf => op2 (default nv) + | Oaddf | Osubf | Omulf | Odivf | Ominf | Omaxf => op2 (default nv) + | Ofmaddf | Ofmsubf => op3 (default nv) | Onegfs | Oabsfs => op1 (default nv) - | Oaddfs | Osubfs | Omulfs | Odivfs => op2 (default nv) + | Oaddfs | Osubfs | Omulfs | Odivfs | Ominfs | Omaxfs => op2 (default nv) + | Oinvfs => op1 (default nv) + | Ofmaddfs | Ofmsubfs => op3 (default nv) | Ofloatofsingle | Osingleoffloat => op1 (default nv) | Ointoffloat | Ointuoffloat => op1 (default nv) | Olongoffloat | Olonguoffloat | Ofloatoflong | Ofloatoflongu => op1 (default nv) | Ointofsingle | Ointuofsingle | Osingleofint | Osingleofintu => op1 (default nv) | Olongofsingle | Olonguofsingle | Osingleoflong | Osingleoflongu => op1 (default nv) | Ocmp c => needs_of_condition c - | Oselect _ | Oselectl _ | Oselectf _ | Oselectfs _ => op3 (default nv) | Oextfz _ _ | Oextfs _ _ | Oextfzl _ _ | Oextfsl _ _ => op1 (default nv) | Oinsf _ _ | Oinsfl _ _ => op2 (default nv) + | Osel c ty => nv :: nv :: needs_of_condition0 c + | Oselimm c imm + | Osellimm c imm => nv :: needs_of_condition0 c end. Definition operation_is_redundant (op: operation) (nv: nval): bool := @@ -229,6 +247,26 @@ Proof. - apply Val.addl_lessdef; trivial. Qed. +Lemma subl_lessdef: + forall v1 v1' v2 v2', + Val.lessdef v1 v1' -> Val.lessdef v2 v2' -> Val.lessdef (Val.subl v1 v2) (Val.subl v1' v2'). +Proof. + intros. inv H. inv H0. auto. destruct v1'; simpl; auto. simpl; auto. +Qed. + +Lemma subl_sound: + forall v1 w1 v2 w2 x, + vagree v1 w1 (default x) -> vagree v2 w2 (default x) -> + vagree (Val.subl v1 v2) (Val.subl w1 w2) x. +Proof. + unfold default; intros. + destruct x; simpl in *; trivial. + - unfold Val.subl. + destruct v1; destruct v2; trivial; destruct Archi.ptr64; simpl; trivial. + destruct (eq_block _ _) ; simpl; trivial. + - apply subl_lessdef; trivial. +Qed. + Lemma mull_sound: forall v1 w1 v2 w2 x, @@ -245,184 +283,57 @@ Proof. trivial. Qed. -Lemma select_sound: - forall cond v0 w0 v1 w1 v2 w2 x, - vagree v0 w0 (default x) -> - vagree v1 w1 (default x) -> - vagree v2 w2 (default x) -> - vagree (eval_select cond v0 v1 v2 m1) (eval_select cond w0 w1 w2 m2) x. -Proof. - intros. - destruct x; simpl in *; trivial. - - rewrite eval_select_to2. - rewrite eval_select_to2. - unfold eval_select2. - assert (Hneedstrue := (needs_of_condition0_sound cond v2 true w2)). - assert (Hneedsfalse := (needs_of_condition0_sound cond v2 false w2)). - destruct (eval_condition0 cond v2 m1) in *; simpl in *; trivial. - destruct b. - + rewrite Hneedstrue; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. - destruct w1; trivial. - apply iagree_refl. - + rewrite Hneedsfalse; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. - destruct w1; trivial. - apply iagree_refl. - - rewrite eval_select_to2. - rewrite eval_select_to2. - unfold eval_select2. - assert (Hneedstrue := (needs_of_condition0_sound cond v2 true w2)). - assert (Hneedsfalse := (needs_of_condition0_sound cond v2 false w2)). - destruct (eval_condition0 cond v2 m1) in *; simpl in *; trivial. - destruct b. - + rewrite Hneedstrue; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. - + rewrite Hneedsfalse; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. -Qed. -Lemma selectl_sound: - forall cond v0 w0 v1 w1 v2 w2 x, - vagree v0 w0 (default x) -> - vagree v1 w1 (default x) -> - vagree v2 w2 (default x) -> - vagree (eval_selectl cond v0 v1 v2 m1) (eval_selectl cond w0 w1 w2 m2) x. +Remark default_idem: forall nv, default (default nv) = default nv. Proof. - intros. - destruct x; simpl in *; trivial. - - rewrite eval_selectl_to2. - rewrite eval_selectl_to2. - unfold eval_selectl2. - assert (Hneedstrue := (needs_of_condition0_sound cond v2 true w2)). - assert (Hneedsfalse := (needs_of_condition0_sound cond v2 false w2)). - destruct (eval_condition0 cond v2 m1) in *; simpl in *; trivial. - destruct b. - + rewrite Hneedstrue; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. - destruct w1; trivial. - + rewrite Hneedsfalse; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. - destruct w1; trivial. - - rewrite eval_selectl_to2. - rewrite eval_selectl_to2. - unfold eval_selectl2. - assert (Hneedstrue := (needs_of_condition0_sound cond v2 true w2)). - assert (Hneedsfalse := (needs_of_condition0_sound cond v2 false w2)). - destruct (eval_condition0 cond v2 m1) in *; simpl in *; trivial. - destruct b. - + rewrite Hneedstrue; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. - + rewrite Hneedsfalse; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. + destruct nv; simpl; trivial. Qed. -Lemma selectf_sound: - forall cond v0 w0 v1 w1 v2 w2 x, - vagree v0 w0 (default x) -> - vagree v1 w1 (default x) -> - vagree v2 w2 (default x) -> - vagree (eval_selectf cond v0 v1 v2 m1) (eval_selectf cond w0 w1 w2 m2) x. +Lemma vagree_triple_op_float : + forall f a b c x y z nv, + (vagree a x (default nv)) -> + (vagree b y (default nv)) -> + (vagree c z (default nv)) -> + (vagree (ExtValues.triple_op_float f a b c) + (ExtValues.triple_op_float f x y z) nv). Proof. - intros. - destruct x; simpl in *; trivial. - - rewrite eval_selectf_to2. - rewrite eval_selectf_to2. - unfold eval_selectf2. - assert (Hneedstrue := (needs_of_condition0_sound cond v2 true w2)). - assert (Hneedsfalse := (needs_of_condition0_sound cond v2 false w2)). - destruct (eval_condition0 cond v2 m1) in *; simpl in *; trivial. - destruct b. - + rewrite Hneedstrue; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. - destruct w1; trivial. - + rewrite Hneedsfalse; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. - destruct w1; trivial. - - rewrite eval_selectf_to2. - rewrite eval_selectf_to2. - unfold eval_selectf2. - assert (Hneedstrue := (needs_of_condition0_sound cond v2 true w2)). - assert (Hneedsfalse := (needs_of_condition0_sound cond v2 false w2)). - destruct (eval_condition0 cond v2 m1) in *; simpl in *; trivial. - destruct b. - + rewrite Hneedstrue; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. - + rewrite Hneedsfalse; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. + induction nv; + intros Hax Hby Hcz. + - trivial. + - simpl in *. destruct a; simpl; trivial. + destruct b; simpl; trivial. + destruct c; simpl; trivial. + - simpl in *. destruct a; simpl; trivial. + destruct b; simpl; trivial. + destruct c; simpl; trivial. + inv Hax. inv Hby. inv Hcz. + simpl. + constructor. Qed. -Lemma selectfs_sound: - forall cond v0 w0 v1 w1 v2 w2 x, - vagree v0 w0 (default x) -> - vagree v1 w1 (default x) -> - vagree v2 w2 (default x) -> - vagree (eval_selectfs cond v0 v1 v2 m1) (eval_selectfs cond w0 w1 w2 m2) x. +Lemma vagree_triple_op_single : + forall f a b c x y z nv, + (vagree a x (default nv)) -> + (vagree b y (default nv)) -> + (vagree c z (default nv)) -> + (vagree (ExtValues.triple_op_single f a b c) + (ExtValues.triple_op_single f x y z) nv). Proof. - intros. - destruct x; simpl in *; trivial. - - rewrite eval_selectfs_to2. - rewrite eval_selectfs_to2. - unfold eval_selectfs2. - assert (Hneedstrue := (needs_of_condition0_sound cond v2 true w2)). - assert (Hneedsfalse := (needs_of_condition0_sound cond v2 false w2)). - destruct (eval_condition0 cond v2 m1) in *; simpl in *; trivial. - destruct b. - + rewrite Hneedstrue; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. - destruct w1; trivial. - + rewrite Hneedsfalse; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. - destruct w1; trivial. - - rewrite eval_selectfs_to2. - rewrite eval_selectfs_to2. - unfold eval_selectfs2. - assert (Hneedstrue := (needs_of_condition0_sound cond v2 true w2)). - assert (Hneedsfalse := (needs_of_condition0_sound cond v2 false w2)). - destruct (eval_condition0 cond v2 m1) in *; simpl in *; trivial. - destruct b. - + rewrite Hneedstrue; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. - + rewrite Hneedsfalse; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. + induction nv; + intros Hax Hby Hcz. + - trivial. + - simpl in *. destruct a; simpl; trivial. + destruct b; simpl; trivial. + destruct c; simpl; trivial. + - simpl in *. destruct a; simpl; trivial. + destruct b; simpl; trivial. + destruct c; simpl; trivial. + inv Hax. inv Hby. inv Hcz. + simpl. + constructor. Qed. -Remark default_idem: forall nv, default (default nv) = default nv. -Proof. - destruct nv; simpl; trivial. -Qed. +Hint Resolve vagree_triple_op_float vagree_triple_op_single : na. Lemma needs_of_operation_sound: forall op args v nv args', @@ -466,19 +377,26 @@ Proof. (* madd *) - apply add_sound; try apply mul_sound; auto with na; rewrite modarith_idem; assumption. - apply add_sound; try apply mul_sound; auto with na; rewrite modarith_idem; assumption. - (* maddl *) -- apply addl_sound; trivial. - apply mull_sound; trivial. - rewrite default_idem; trivial. - rewrite default_idem; trivial. - (* select *) -- apply select_sound; trivial. - (* selectl *) -- apply selectl_sound; trivial. - (* selectf *) -- apply selectf_sound; trivial. - (* selectfs *) -- apply selectfs_sound; trivial. +- repeat rewrite ExtValues.sub_add_neg. + apply add_sound; trivial. + apply neg_sound; trivial. + rewrite modarith_idem. + apply mul_sound; + rewrite modarith_idem; trivial. +- destruct (eval_condition0 _ _ _) as [b|] eqn:EC. + erewrite needs_of_condition0_sound by eauto. + apply select_sound; auto. + simpl; auto with na. + (* select imm *) +- destruct (eval_condition0 _ _ _) as [b|] eqn:EC. + { erewrite needs_of_condition0_sound by eauto. + apply select_sound; auto with na. } + simpl; auto with na. + (* select long imm *) +- destruct (eval_condition0 _ _ _) as [b|] eqn:EC. + { erewrite needs_of_condition0_sound by eauto. + apply select_sound; auto with na. } + simpl; auto with na. Qed. Lemma operation_is_redundant_sound: diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 5e80589b..92061d04 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -79,8 +79,13 @@ Inductive operation : Type := | Ocast16signed (**r [rd] is 16-bit sign extension of [r1] *) | Oadd (**r [rd = r1 + r2] *) | Oaddimm (n: int) (**r [rd = r1 + n] *) + | Oaddx (shift: shift1_4) (**r [rd = r1 << shift + r2] *) + | Oaddximm (shift: shift1_4) (n: int) (**r [rd = r1 << shift + n] *) | Oneg (**r [rd = - r1] *) | Osub (**r [rd = r1 - r2] *) + | Orevsubimm (n: int) (**r [rd = n - r1] *) + | Orevsubx (shift: shift1_4) (**r [rd = r2 -r1 << shift] *) + | Orevsubximm (shift: shift1_4) (n: int) (**r [rd = n -r1 << shift] *) | Omul (**r [rd = r1 * r2] *) | Omulimm (n: int) (**r [rd = r1 * n] *) | Omulhs (**r [rd = high part of r1 * r2, signed] *) @@ -95,27 +100,28 @@ Inductive operation : Type := | Onandimm (n: int) (**r [rd = ~(r1 & n)] *) | Oor (**r [rd = r1 | r2] *) | Oorimm (n: int) (**r [rd = r1 | n] *) - | Onor (**r [rd = r1 | r2] *) - | Onorimm (n: int) (**r [rd = r1 | n] *) + | Onor (**r [rd = ~(r1 | r2)] *) + | Onorimm (n: int) (**r [rd = ~(r1 | n)] *) | Oxor (**r [rd = r1 ^ r2] *) | Oxorimm (n: int) (**r [rd = r1 ^ n] *) | Onxor (**r [rd = ~(r1 ^ r2)] *) | Onxorimm (n: int) (**r [rd = ~(r1 ^ n)] *) | Onot (**r [rd = ~r1] *) - | Oandn (**r [rd = (~r1) ^ r2] *) - | Oandnimm (n: int) (**r [rd = (~r1) ^ n] *) + | Oandn (**r [rd = (~r1) & r2] *) + | Oandnimm (n: int) (**r [rd = (~r1) & n] *) | Oorn (**r [rd = (~r1) | r2] *) | Oornimm (n: int) (**r [rd = (~r1) | n] *) | 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) *) - | Oshru (**r [rd = r1 >> r2] (unsigned) *) - | Oshruimm (n: int) (**r [rd = r1 >> n] (unsigned) *) + | Oshr (**r [rd = r1 >>s r2] (signed) *) + | Oshrimm (n: int) (**r [rd = r1 >>s n] (signed) *) + | Oshru (**r [rd = r1 >>u r2] (unsigned) *) + | Oshruimm (n: int) (**r [rd = r1 >>x n] (unsigned) *) | Oshrximm (n: int) (**r [rd = r1 / 2^n] (signed) *) | Ororimm (n: int) (**r rotate right immediate *) | Omadd (**r [rd = rd + r1 * r2] *) | Omaddimm (n: int) (**r [rd = rd + r1 * imm] *) + | Omsub (**r [rd = rd - r1 * r2] *) (*c 64-bit integer arithmetic: *) | Omakelong (**r [rd = r1 << 32 | r2] *) | Olowlong (**r [rd = low-word(r1)] *) @@ -124,6 +130,11 @@ Inductive operation : Type := | Ocast32unsigned (**r [rd] is 32-bit zero extension of [r1] *) | Oaddl (**r [rd = r1 + r2] *) | Oaddlimm (n: int64) (**r [rd = r1 + n] *) + | Oaddxl (shift: shift1_4) (**r [rd = r1 << shift + r2] *) + | Oaddxlimm (shift: shift1_4) (n: int64) (**r [rd = r1 << shift + n] *) + | Orevsublimm (n: int64) (**r [rd = n - r1] *) + | Orevsubxl (shift: shift1_4) (**r [rd = r2 -r1 << shift] *) + | Orevsubxlimm (shift: shift1_4) (n: int64) (**r [rd = n -r1 << shift] *) | Onegl (**r [rd = - r1] *) | Osubl (**r [rd = r1 - r2] *) | Omull (**r [rd = r1 * r2] *) @@ -147,8 +158,8 @@ Inductive operation : Type := | Onxorl (**r [rd = ~(r1 ^ r2)] *) | Onxorlimm (n: int64) (**r [rd = ~(r1 ^ n)] *) | Onotl (**r [rd = ~r1] *) - | Oandnl (**r [rd = (~r1) ^ r2] *) - | Oandnlimm (n: int64) (**r [rd = (~r1) ^ n] *) + | Oandnl (**r [rd = (~r1) & r2] *) + | Oandnlimm (n: int64) (**r [rd = (~r1) & n] *) | Oornl (**r [rd = (~r1) | r2] *) | Oornlimm (n: int64) (**r [rd = (~r1) | n] *) | Oshll (**r [rd = r1 << r2] *) @@ -160,6 +171,7 @@ Inductive operation : Type := | Oshrxlimm (n: int) (**r [rd = r1 / 2^n] (signed) *) | Omaddl (**r [rd = rd + r1 * r2] *) | Omaddlimm (n: int64) (**r [rd = rd + r1 * imm] *) + | Omsubl (**r [rd = rd - r1 * r2] *) (*c Floating-point arithmetic: *) | Onegf (**r [rd = - r1] *) | Oabsf (**r [rd = abs(r1)] *) @@ -167,12 +179,21 @@ Inductive operation : Type := | Osubf (**r [rd = r1 - r2] *) | Omulf (**r [rd = r1 * r2] *) | Odivf (**r [rd = r1 / r2] *) + | Ominf + | Omaxf + | Ofmaddf + | Ofmsubf | 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] *) + | Ominfs + | Omaxfs + | Oinvfs + | Ofmaddfs + | Ofmsubfs | 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: *) @@ -192,16 +213,15 @@ Inductive operation : Type := | Osingleoflongu (**r [rd = float32_of_unsigned_int(r1)] *) (*c Boolean tests: *) | Ocmp (cond: condition) (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) - | Oselect (cond: condition0) (**r [rd = if cond r3 then r2 else r1] *) - | Oselectl (cond: condition0) (**r [rd = if cond r3 then r2 else r1] *) - | Oselectf (cond: condition0) (**r [rd = if cond r3 then r2 else r1] *) - | Oselectfs (cond: condition0) (**r [rd = if cond r3 then r2 else r1] *) | Oextfz (stop : Z) (start : Z) | Oextfs (stop : Z) (start : Z) | Oextfzl (stop : Z) (start : Z) | Oextfsl (stop : Z) (start : Z) | Oinsf (stop : Z) (start : Z) - | Oinsfl (stop : Z) (start : Z). + | Oinsfl (stop : Z) (start : Z) + | Osel (c0 : condition0) (ty : typ) + | Oselimm (c0 : condition0) (imm: int) + | Osellimm (c0 : condition0) (imm: int64). (** Addressing modes. [r1], [r2], etc, are the arguments to the addressing. *) @@ -235,9 +255,14 @@ Proof. decide equality. Defined. +Definition eq_shift1_4 (x y : shift1_4): {x=y} + {x<>y}. +Proof. + decide equality. +Defined. + Definition eq_operation: forall (x y: operation), {x=y} + {x<>y}. Proof. - generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_condition eq_condition0 Z.eq_dec; intros. + generalize typ_eq Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_condition eq_condition0 Z.eq_dec eq_shift1_4; intros. decide equality. Defined. @@ -287,90 +312,14 @@ Definition eval_condition0 (cond: condition0) (v1: val) (m: mem): option bool := | Ccomplu0 c => Val.cmplu_bool (Mem.valid_pointer m) c v1 (Vlong Int64.zero) end. -Definition eval_select (cond : condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val := - match v0, v1, (eval_condition0 cond vselect m) with - | Vint i0, Vint i1, Some bval => Vint (if bval then i1 else i0) - | _,_,_ => Vundef - end. - -Definition eval_select2 (cond : condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val := - match (eval_condition0 cond vselect m), v0, v1 with - | Some bval, Vint i0, Vint i1 => Vint (if bval then i1 else i0) - | _,_,_ => Vundef - end. - -Lemma eval_select_to2: forall cond v0 v1 vselect m, - (eval_select cond v0 v1 vselect m) = - (eval_select2 cond v0 v1 vselect m). -Proof. - intros. - unfold eval_select2. - destruct v0; destruct v1; simpl; destruct (eval_condition0 cond vselect m); simpl; reflexivity. -Qed. - -Definition eval_selectl (cond: condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val := - match v0, v1, (eval_condition0 cond vselect m) with - | Vlong i0, Vlong i1, Some bval => Vlong (if bval then i1 else i0) - | _,_,_ => Vundef - end. - -Definition eval_selectl2 (cond : condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val := - match (eval_condition0 cond vselect m), v0, v1 with - | Some bval, Vlong i0, Vlong i1 => Vlong (if bval then i1 else i0) - | _,_,_ => Vundef +Definition negate_condition0 (cond0 : condition0) : condition0 := + match cond0 with + | Ccomp0 c => Ccomp0 (negate_comparison c) + | Ccompu0 c => Ccompu0 (negate_comparison c) + | Ccompl0 c => Ccompl0 (negate_comparison c) + | Ccomplu0 c => Ccomplu0 (negate_comparison c) end. -Lemma eval_selectl_to2: forall cond v0 v1 vselect m, - (eval_selectl cond v0 v1 vselect m) = - (eval_selectl2 cond v0 v1 vselect m). -Proof. - intros. - unfold eval_selectl2. - destruct v0; destruct v1; simpl; destruct (eval_condition0 cond vselect m); simpl; reflexivity. -Qed. - -Definition eval_selectf (cond: condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val := - match v0, v1, (eval_condition0 cond vselect m) with - | Vfloat i0, Vfloat i1, Some bval => Vfloat (if bval then i1 else i0) - | _,_,_ => Vundef - end. - -Definition eval_selectf2 (cond : condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val := - match (eval_condition0 cond vselect m), v0, v1 with - | Some bval, Vfloat i0, Vfloat i1 => Vfloat (if bval then i1 else i0) - | _,_,_ => Vundef - end. - -Lemma eval_selectf_to2: forall cond v0 v1 vselect m, - (eval_selectf cond v0 v1 vselect m) = - (eval_selectf2 cond v0 v1 vselect m). -Proof. - intros. - unfold eval_selectf2. - destruct v0; destruct v1; simpl; destruct (eval_condition0 cond vselect m); simpl; reflexivity. -Qed. - -Definition eval_selectfs (cond: condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val := - match v0, v1, (eval_condition0 cond vselect m) with - | Vsingle i0, Vsingle i1, Some bval => Vsingle (if bval then i1 else i0) - | _,_,_ => Vundef - end. - -Definition eval_selectfs2 (cond : condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val := - match (eval_condition0 cond vselect m), v0, v1 with - | Some bval, Vsingle i0, Vsingle i1 => Vsingle (if bval then i1 else i0) - | _,_,_ => Vundef - end. - -Lemma eval_selectfs_to2: forall cond v0 v1 vselect m, - (eval_selectfs cond v0 v1 vselect m) = - (eval_selectfs2 cond v0 v1 vselect m). -Proof. - intros. - unfold eval_selectfs2. - destruct v0; destruct v1; simpl; destruct (eval_condition0 cond vselect m); simpl; reflexivity. -Qed. - Definition eval_operation (F V: Type) (genv: Genv.t F V) (sp: val) (op: operation) (vl: list val) (m: mem): option val := @@ -386,8 +335,13 @@ Definition eval_operation | Ocast16signed, v1 :: nil => Some (Val.sign_ext 16 v1) | Oadd, v1 :: v2 :: nil => Some (Val.add v1 v2) | Oaddimm n, v1 :: nil => Some (Val.add v1 (Vint n)) + | Oaddx s14, v1 :: v2 :: nil => Some (addx (int_of_shift1_4 s14) v1 v2) + | Oaddximm s14 n, v1 :: nil => Some (addx (int_of_shift1_4 s14) v1 (Vint n)) | Oneg, v1 :: nil => Some (Val.neg v1) | Osub, v1 :: v2 :: nil => Some (Val.sub v1 v2) + | Orevsubimm n, v1 :: nil => Some (Val.sub (Vint n) v1) + | Orevsubx shift, v1 :: v2 :: nil => Some (ExtValues.revsubx (int_of_shift1_4 shift) v1 v2) + | Orevsubximm shift n, v1 :: nil => Some (ExtValues.revsubx (int_of_shift1_4 shift) v1 (Vint n)) | Omul, v1 :: v2 :: nil => Some (Val.mul v1 v2) | Omulimm n, v1 :: nil => Some (Val.mul v1 (Vint n)) | Omulhs, v1::v2::nil => Some (Val.mulhs v1 v2) @@ -423,6 +377,7 @@ Definition eval_operation | Oshrximm n, v1::nil => Val.shrx v1 (Vint n) | Omadd, v1::v2::v3::nil => Some (Val.add v1 (Val.mul v2 v3)) | (Omaddimm n), v1::v2::nil => Some (Val.add v1 (Val.mul v2 (Vint n))) + | Omsub, v1::v2::v3::nil => Some (Val.sub v1 (Val.mul v2 v3)) | Omakelong, v1::v2::nil => Some (Val.longofwords v1 v2) | Olowlong, v1::nil => Some (Val.loword v1) @@ -431,8 +386,13 @@ Definition eval_operation | Ocast32unsigned, v1 :: nil => Some (Val.longofintu v1) | Oaddl, v1 :: v2 :: nil => Some (Val.addl v1 v2) | Oaddlimm n, v1::nil => Some (Val.addl v1 (Vlong n)) + | Oaddxl s14, v1 :: v2 :: nil => Some (addxl (int_of_shift1_4 s14) v1 v2) + | Oaddxlimm s14 n, v1 :: nil => Some (addxl (int_of_shift1_4 s14) v1 (Vlong n)) | Onegl, v1::nil => Some (Val.negl v1) | Osubl, v1::v2::nil => Some (Val.subl v1 v2) + | Orevsublimm n, v1 :: nil => Some (Val.subl (Vlong n) v1) + | Orevsubxl shift, v1 :: v2 :: nil => Some (ExtValues.revsubxl (int_of_shift1_4 shift) v1 v2) + | Orevsubxlimm shift n, v1 :: nil => Some (ExtValues.revsubxl (int_of_shift1_4 shift) v1 (Vlong n)) | Omull, v1::v2::nil => Some (Val.mull v1 v2) | Omullimm n, v1::nil => Some (Val.mull v1 (Vlong n)) | Omullhs, v1::v2::nil => Some (Val.mullhs v1 v2) @@ -467,6 +427,7 @@ Definition eval_operation | Oshrxlimm n, v1::nil => Val.shrxl v1 (Vint n) | Omaddl, v1::v2::v3::nil => Some (Val.addl v1 (Val.mull v2 v3)) | (Omaddlimm n), v1::v2::nil => Some (Val.addl v1 (Val.mull v2 (Vlong n))) + | Omsubl, v1::v2::v3::nil => Some (Val.subl v1 (Val.mull v2 v3)) | Onegf, v1::nil => Some (Val.negf v1) | Oabsf, v1::nil => Some (Val.absf v1) @@ -474,12 +435,23 @@ Definition eval_operation | Osubf, v1::v2::nil => Some (Val.subf v1 v2) | Omulf, v1::v2::nil => Some (Val.mulf v1 v2) | Odivf, v1::v2::nil => Some (Val.divf v1 v2) + | Ominf, v1::v2::nil => Some (ExtValues.minf v1 v2) + | Omaxf, v1::v2::nil => Some (ExtValues.maxf v1 v2) + | Ofmaddf, v1::v2::v3::nil => Some (ExtValues.fmaddf v1 v2 v3) + | Ofmsubf, v1::v2::v3::nil => Some (ExtValues.fmsubf v1 v2 v3) + | Onegfs, v1::nil => Some (Val.negfs v1) | Oabsfs, v1::nil => Some (Val.absfs v1) | Oaddfs, v1::v2::nil => Some (Val.addfs v1 v2) | Osubfs, v1::v2::nil => Some (Val.subfs v1 v2) | Omulfs, v1::v2::nil => Some (Val.mulfs v1 v2) | Odivfs, v1::v2::nil => Some (Val.divfs v1 v2) + | Ominfs, v1::v2::nil => Some (ExtValues.minfs v1 v2) + | Omaxfs, v1::v2::nil => Some (ExtValues.maxfs v1 v2) + | Oinvfs, v1::nil => Some (ExtValues.invfs v1) + | Ofmaddfs, v1::v2::v3::nil => Some (ExtValues.fmaddfs v1 v2 v3) + | Ofmsubfs, v1::v2::v3::nil => Some (ExtValues.fmsubfs v1 v2 v3) + | Osingleoffloat, v1::nil => Some (Val.singleoffloat v1) | Ofloatofsingle, v1::nil => Some (Val.floatofsingle v1) | Ointoffloat, v1::nil => Val.intoffloat v1 @@ -497,16 +469,15 @@ Definition eval_operation | Osingleoflong, v1::nil => Val.singleoflong v1 | Osingleoflongu, v1::nil => Val.singleoflongu v1 | Ocmp c, _ => Some (Val.of_optbool (eval_condition c vl m)) - | (Oselect cond), v0::v1::vselect::nil => Some (eval_select cond v0 v1 vselect m) - | (Oselectl cond), v0::v1::vselect::nil => Some (eval_selectl cond v0 v1 vselect m) - | (Oselectf cond), v0::v1::vselect::nil => Some (eval_selectf cond v0 v1 vselect m) - | (Oselectfs cond), v0::v1::vselect::nil => Some (eval_selectfs cond v0 v1 vselect m) | (Oextfz stop start), v0::nil => Some (extfz stop start v0) | (Oextfs stop start), v0::nil => Some (extfs stop start v0) | (Oextfzl stop start), v0::nil => Some (extfzl stop start v0) | (Oextfsl stop start), v0::nil => Some (extfsl stop start v0) | (Oinsf stop start), v0::v1::nil => Some (insf stop start v0 v1) | (Oinsfl stop start), v0::v1::nil => Some (insfl stop start v0 v1) + | Osel c ty, v1::v2::vc::nil => Some(Val.select (eval_condition0 c vc m) v1 v2 ty) + | Oselimm c imm, v1::vc::nil => Some(Val.select (eval_condition0 c vc m) v1 (Vint imm) Tint) + | Osellimm c imm, v1::vc::nil => Some(Val.select (eval_condition0 c vc m) v1 (Vlong imm) Tlong) | _, _ => None end. @@ -583,8 +554,13 @@ Definition type_of_operation (op: operation) : list typ * typ := | Ocast16signed => (Tint :: nil, Tint) | Oadd => (Tint :: Tint :: nil, Tint) | Oaddimm _ => (Tint :: nil, Tint) + | Oaddx _ => (Tint :: Tint :: nil, Tint) + | Oaddximm _ _ => (Tint :: nil, Tint) | Oneg => (Tint :: nil, Tint) | Osub => (Tint :: Tint :: nil, Tint) + | Orevsubimm _ => (Tint :: nil, Tint) + | Orevsubx _ => (Tint :: Tint :: nil, Tint) + | Orevsubximm _ _ => (Tint :: nil, Tint) | Omul => (Tint :: Tint :: nil, Tint) | Omulimm _ => (Tint :: nil, Tint) | Omulhs => (Tint :: Tint :: nil, Tint) @@ -620,6 +596,7 @@ Definition type_of_operation (op: operation) : list typ * typ := | Ororimm _ => (Tint :: nil, Tint) | Omadd => (Tint :: Tint :: Tint :: nil, Tint) | Omaddimm _ => (Tint :: Tint :: nil, Tint) + | Omsub => (Tint :: Tint :: Tint :: nil, Tint) | Omakelong => (Tint :: Tint :: nil, Tlong) | Olowlong => (Tlong :: nil, Tint) @@ -628,6 +605,11 @@ Definition type_of_operation (op: operation) : list typ * typ := | Ocast32unsigned => (Tint :: nil, Tlong) | Oaddl => (Tlong :: Tlong :: nil, Tlong) | Oaddlimm _ => (Tlong :: nil, Tlong) + | Oaddxl _ => (Tlong :: Tlong :: nil, Tlong) + | Oaddxlimm _ _ => (Tlong :: nil, Tlong) + | Orevsublimm _ => (Tlong :: nil, Tlong) + | Orevsubxl _ => (Tlong :: Tlong :: nil, Tlong) + | Orevsubxlimm _ _ => (Tlong :: nil, Tlong) | Onegl => (Tlong :: nil, Tlong) | Osubl => (Tlong :: Tlong :: nil, Tlong) | Omull => (Tlong :: Tlong :: nil, Tlong) @@ -664,19 +646,29 @@ Definition type_of_operation (op: operation) : list typ * typ := | Oshrxlimm _ => (Tlong :: nil, Tlong) | Omaddl => (Tlong :: Tlong :: Tlong :: nil, Tlong) | Omaddlimm _ => (Tlong :: Tlong :: nil, Tlong) + | Omsubl => (Tlong :: Tlong :: Tlong :: nil, Tlong) | Onegf => (Tfloat :: nil, Tfloat) | Oabsf => (Tfloat :: nil, Tfloat) - | Oaddf => (Tfloat :: Tfloat :: nil, Tfloat) - | Osubf => (Tfloat :: Tfloat :: nil, Tfloat) - | Omulf => (Tfloat :: Tfloat :: nil, Tfloat) - | Odivf => (Tfloat :: Tfloat :: nil, Tfloat) + | Oaddf + | Osubf + | Omulf + | Odivf + | Ominf + | Omaxf => (Tfloat :: Tfloat :: nil, Tfloat) + | Ofmaddf | Ofmsubf => (Tfloat :: Tfloat :: Tfloat :: nil, Tfloat) + | Onegfs => (Tsingle :: nil, Tsingle) | Oabsfs => (Tsingle :: nil, Tsingle) - | Oaddfs => (Tsingle :: Tsingle :: nil, Tsingle) - | Osubfs => (Tsingle :: Tsingle :: nil, Tsingle) - | Omulfs => (Tsingle :: Tsingle :: nil, Tsingle) - | Odivfs => (Tsingle :: Tsingle :: nil, Tsingle) + | Oaddfs + | Osubfs + | Omulfs + | Odivfs + | Ominfs + | Omaxfs => (Tsingle :: Tsingle :: nil, Tsingle) + | Oinvfs => (Tsingle :: nil, Tsingle) + | Ofmaddfs | Ofmsubfs => (Tsingle :: Tsingle :: Tsingle :: nil, Tsingle) + | Osingleoffloat => (Tfloat :: nil, Tsingle) | Ofloatofsingle => (Tsingle :: nil, Tfloat) | Ointoffloat => (Tfloat :: nil, Tint) @@ -693,16 +685,14 @@ Definition type_of_operation (op: operation) : list typ * typ := | Olonguofsingle => (Tsingle :: nil, Tlong) | Osingleoflong => (Tlong :: nil, Tsingle) | Osingleoflongu => (Tlong :: nil, Tsingle) - | Ocmp c => (type_of_condition c, Tint) - - | Oselect cond => (Tint :: Tint :: (arg_type_of_condition0 cond) :: nil, Tint) - | Oselectl cond => (Tlong :: Tlong :: (arg_type_of_condition0 cond) :: nil, Tlong) - | Oselectf cond => (Tfloat :: Tfloat :: (arg_type_of_condition0 cond) :: nil, Tfloat) - | Oselectfs cond => (Tsingle :: Tsingle :: (arg_type_of_condition0 cond) :: nil, Tsingle) + | Ocmp c => (type_of_condition c, Tint) | Oextfz _ _ | Oextfs _ _ => (Tint :: nil, Tint) | Oextfzl _ _ | Oextfsl _ _ => (Tlong :: nil, Tlong) | Oinsf _ _ => (Tint :: Tint :: nil, Tint) | Oinsfl _ _ => (Tlong :: Tlong :: nil, Tlong) + | Osel c ty => (ty :: ty :: arg_type_of_condition0 c :: nil, ty) + | Oselimm c ty => (Tint :: arg_type_of_condition0 c :: nil, Tint) + | Osellimm c ty => (Tlong :: arg_type_of_condition0 c :: nil, Tlong) end. (* FIXME: two Tptr ?! *) @@ -736,6 +726,32 @@ Proof. intros. unfold Val.has_type, Val.addl. destruct Archi.ptr64, v1, v2; auto. Qed. +Remark type_sub: + forall v1 v2, Val.has_type (Val.sub v1 v2) Tint. +Proof. + intros. unfold Val.has_type, Val.sub. destruct Archi.ptr64, v1, v2; simpl; auto. + destruct (eq_block _ _); auto. +Qed. + +Remark type_subl: + forall v1 v2, Val.has_type (Val.subl v1 v2) Tlong. +Proof. + intros. unfold Val.has_type, Val.subl. destruct Archi.ptr64, v1, v2; simpl; auto. + destruct (eq_block _ _); auto. +Qed. + +Remark type_shl: + forall v1 v2, Val.has_type (Val.shl v1 v2) Tint. +Proof. + destruct v1, v2; simpl; trivial; destruct (Int.ltu _ _); simpl; trivial. +Qed. + +Remark type_shll: + forall v1 v2, Val.has_type (Val.shll v1 v2) Tlong. +Proof. + destruct v1, v2; simpl; trivial; destruct (Int.ltu _ _); simpl; trivial. +Qed. + Lemma type_of_operation_sound: forall op vl sp v m, op <> Omove -> @@ -761,9 +777,18 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* add, addimm *) - apply type_add. - apply type_add. + (* addx, addximm *) + - apply type_add. + - destruct v0; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. (* neg, sub *) - destruct v0... - - unfold Val.sub. destruct v0; destruct v1... + - apply type_sub. + (* revsubimm, revsubx, revsubximm *) + - destruct v0... + - apply type_sub. + - destruct v0; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. (* mul, mulimm, mulhs, mulhu *) - destruct v0; destruct v1... - destruct v0... @@ -819,8 +844,10 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* shrimm *) - destruct v0; simpl... (* madd *) - - destruct v0; destruct v1; destruct v2... - - destruct v0; destruct v1... + - apply type_add. + - apply type_add. + (* msub *) + - apply type_sub. (* makelong, lowlong, highlong *) - destruct v0; destruct v1... - destruct v0... @@ -831,11 +858,17 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* addl, addlimm *) - apply type_addl. - apply type_addl. + (* addxl addxlimm *) + - apply type_addl. + - destruct v0; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. (* negl, subl *) - destruct v0... - - unfold Val.subl. destruct v0; destruct v1... - unfold Val.has_type; destruct Archi.ptr64... - destruct (eq_block b b0)... + - apply type_subl. + - destruct v0; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. + - destruct v0... + - apply type_subl. (* mull, mullhs, mullhu *) - destruct v0; destruct v1... - destruct v0... @@ -889,10 +922,10 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* shrxl *) - destruct v0; simpl in H0; try discriminate. destruct (Int.ltu n (Int.repr 63)); inv H0... (* maddl, maddlim *) - - destruct v0; destruct v1; destruct v2; simpl; trivial. - destruct Archi.ptr64; simpl; trivial. - - destruct v0; destruct v1; simpl; trivial. - destruct Archi.ptr64; simpl; trivial. + - apply type_addl. + - apply type_addl. + (* msubl *) + - apply type_subl. (* negf, absf *) - destruct v0... - destruct v0... @@ -902,6 +935,12 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* mulf, divf *) - destruct v0; destruct v1... - destruct v0; destruct v1... + (* minf, maxf *) + - destruct v0; destruct v1... + - destruct v0; destruct v1... + (* fmaddf, fmsubf *) + - destruct v0; destruct v1; destruct v2... + - destruct v0; destruct v1; destruct v2... (* negfs, absfs *) - destruct v0... - destruct v0... @@ -911,6 +950,14 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* mulfs, divfs *) - destruct v0; destruct v1... - destruct v0; destruct v1... + (* minfs, maxfs *) + - destruct v0; destruct v1... + - destruct v0; destruct v1... + (* invfs *) + - destruct v0... + (* fmaddfs, fmsubfs *) + - destruct v0; destruct v1; destruct v2... + - destruct v0; destruct v1; destruct v2... (* singleoffloat, floatofsingle *) - destruct v0... - destruct v0... @@ -937,43 +984,6 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0; simpl in H0; inv H0... (* cmp *) - destruct (eval_condition cond vl m)... destruct b... - (* select *) - - destruct v0; destruct v1; simpl in *; try discriminate; trivial. - destruct cond; destruct v2; simpl in *; trivial. - + destruct Archi.ptr64; simpl; trivial. - destruct (_ && _); simpl; trivial. - destruct (Val.cmp_different_blocks _); simpl; trivial. - + destruct Archi.ptr64; simpl; trivial. - destruct (_ && _); simpl; trivial. - destruct (Val.cmp_different_blocks _); simpl; trivial. - (* selectl *) - - destruct v0; destruct v1; simpl in *; try discriminate; trivial. - destruct cond; destruct v2; simpl in *; trivial. - + destruct Archi.ptr64; simpl; trivial. - destruct (_ && _); simpl; trivial. - destruct (Val.cmp_different_blocks _); simpl; trivial. - + destruct Archi.ptr64; simpl; trivial. - destruct (_ && _); simpl; trivial. - destruct (Val.cmp_different_blocks _); simpl; trivial. - - (* selectf *) - - destruct v0; destruct v1; simpl in *; try discriminate; trivial. - destruct cond; destruct v2; simpl in *; trivial. - + destruct Archi.ptr64; simpl; trivial. - destruct (_ && _); simpl; trivial. - destruct (Val.cmp_different_blocks _); simpl; trivial. - + destruct Archi.ptr64; simpl; trivial. - destruct (_ && _); simpl; trivial. - destruct (Val.cmp_different_blocks _); simpl; trivial. - (* selectfs *) - - destruct v0; destruct v1; simpl in *; try discriminate; trivial. - destruct cond; destruct v2; simpl in *; trivial. - + destruct Archi.ptr64; simpl; trivial. - destruct (_ && _); simpl; trivial. - destruct (Val.cmp_different_blocks _); simpl; trivial. - + destruct Archi.ptr64; simpl; trivial. - destruct (_ && _); simpl; trivial. - destruct (Val.cmp_different_blocks _); simpl; trivial. (* extfz *) - unfold extfz. destruct (is_bitfield _ _). @@ -1006,8 +1016,48 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). + destruct v0; destruct v1; simpl; trivial. destruct (Int.ltu _ _); simpl; trivial. + constructor. + (* Osel *) + - unfold Val.select. destruct (eval_condition0 _ _ m). + + apply Val.normalize_type. + + constructor. + (* Oselimm *) + - unfold Val.select. destruct (eval_condition0 _ _ m). + + apply Val.normalize_type. + + constructor. + (* Osellimm *) + - unfold Val.select. destruct (eval_condition0 _ _ m). + + apply Val.normalize_type. + + constructor. Qed. +Definition is_trapping_op (op : operation) := + match op with + | Odiv | Odivl | Odivu | Odivlu + | Omod | Omodl | Omodu | Omodlu + | Oshrximm _ | Oshrxlimm _ + | Ointoffloat | Ointuoffloat + | Ointofsingle | Ointuofsingle + | Olongoffloat | Olonguoffloat + | Olongofsingle | Olonguofsingle + | Osingleofint | Osingleofintu + | Osingleoflong | Osingleoflongu + | Ofloatoflong | Ofloatoflongu => true + | _ => false + end. + +Lemma is_trapping_op_sound: + forall op vl sp m, + op <> Omove -> + is_trapping_op op = false -> + (List.length vl) = (List.length (fst (type_of_operation op))) -> + eval_operation genv sp op vl m <> None. +Proof. + destruct op; intros; simpl in *; try congruence. + all: try (destruct vl as [ | vh1 vl1]; try discriminate). + all: try (destruct vl1 as [ | vh2 vl2]; try discriminate). + all: try (destruct vl2 as [ | vh3 vl3]; try discriminate). + all: try (destruct vl3 as [ | vh4 vl4]; try discriminate). +Qed. End SOUNDNESS. (** * Manipulating and transforming operations *) @@ -1166,19 +1216,10 @@ Definition op_depends_on_memory (op: operation) : bool := | Ocmp (Ccompuimm _ _) => negb Archi.ptr64 | Ocmp (Ccomplu _) => Archi.ptr64 | Ocmp (Ccompluimm _ _) => Archi.ptr64 + + | Osel (Ccompu0 _) _ | Oselimm (Ccompu0 _) _ | Osellimm (Ccompu0 _) _ => negb Archi.ptr64 + | Osel (Ccomplu0 _) _ | Oselimm (Ccomplu0 _) _ | Osellimm (Ccomplu0 _) _ => Archi.ptr64 - | Oselect (Ccompu0 _) => negb Archi.ptr64 - | Oselect (Ccomplu0 _) => Archi.ptr64 - - | Oselectl (Ccompu0 _) => negb Archi.ptr64 - | Oselectl (Ccomplu0 _) => Archi.ptr64 - - | Oselectf (Ccompu0 _) => negb Archi.ptr64 - | Oselectf (Ccomplu0 _) => Archi.ptr64 - - | Oselectfs (Ccompu0 _) => negb Archi.ptr64 - | Oselectfs (Ccomplu0 _) => Archi.ptr64 - | _ => false end. @@ -1187,10 +1228,19 @@ Lemma op_depends_on_memory_correct: op_depends_on_memory op = false -> eval_operation ge sp op args m1 = eval_operation ge sp op args m2. Proof. - intros until m2. destruct op; simpl; try congruence; - - destruct cond; simpl; intros SF; auto; rewrite ? negb_false_iff in SF; - unfold eval_select, eval_selectl, eval_selectf, eval_selectfs, eval_condition0, Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. + intros until m2. destruct op; simpl; try congruence. + - destruct cond; simpl; try congruence; + intros SF; auto; rewrite ? negb_false_iff in SF; + unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. + - destruct c0; simpl; try congruence; + intros SF; auto; rewrite ? negb_false_iff in SF; + unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. + - destruct c0; simpl; try congruence; + intros SF; auto; rewrite ? negb_false_iff in SF; + unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. + - destruct c0; simpl; try congruence; + 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 *) @@ -1359,9 +1409,19 @@ Proof. (* add, addimm *) - apply Val.add_inject; auto. - apply Val.add_inject; auto. + (* addx, addximm *) + - apply Val.add_inject; trivial. + inv H4; inv H2; simpl; try destruct (Int.ltu _ _); simpl; auto. + - inv H4; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. (* neg, sub *) - inv H4; simpl; auto. - apply Val.sub_inject; auto. + (* revsubimm, revsubx, revsubximm *) + - inv H4; simpl; trivial. + - apply Val.sub_inject; trivial. + inv H4; inv H2; simpl; try destruct (Int.ltu _ _); simpl; auto. + - inv H4; simpl; try destruct (Int.ltu _ _); simpl; auto. (* mul, mulimm, mulhs, mulhu *) - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. @@ -1424,6 +1484,9 @@ Proof. (* madd, maddim *) - inv H2; inv H3; inv H4; simpl; auto. - inv H2; inv H4; simpl; auto. + (* msub *) + - apply Val.sub_inject; auto. + inv H3; inv H2; simpl; auto. (* makelong, highlong, lowlong *) - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. @@ -1434,9 +1497,21 @@ Proof. (* addl, addlimm *) - apply Val.addl_inject; auto. - apply Val.addl_inject; auto. + (* addxl, addxlimm *) + - apply Val.addl_inject; auto. + inv H4; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. + - inv H4; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. (* negl, subl *) - inv H4; simpl; auto. - apply Val.subl_inject; auto. + inv H4; inv H2; simpl; trivial; + destruct (Int.ltu _ _); simpl; trivial. + - inv H4; simpl; trivial; + destruct (Int.ltu _ _); simpl; trivial. + - inv H4; simpl; auto. + - apply Val.subl_inject; auto. (* mull, mullhs, mullhu *) - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. @@ -1500,6 +1575,9 @@ Proof. inv H2; inv H3; inv H4; simpl; auto. - apply Val.addl_inject; auto. inv H4; inv H2; simpl; auto. + (* msubl, msublimm *) + - apply Val.subl_inject; auto. + inv H2; inv H3; inv H4; simpl; auto. (* negf, absf *) - inv H4; simpl; auto. @@ -1510,6 +1588,12 @@ Proof. (* mulf, divf *) - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. + (* minf, maxf *) + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + (* fmaddf, fmsubf *) + - inv H4; inv H3; inv H2; simpl; auto. + - inv H4; inv H3; inv H2; simpl; auto. (* negfs, absfs *) - inv H4; simpl; auto. - inv H4; simpl; auto. @@ -1519,6 +1603,14 @@ Proof. (* mulfs, divfs *) - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. + (* minfs, maxfs *) + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + (* invfs *) + - inv H4; simpl; auto. + (* fmaddfs, fmsubfs *) + - inv H4; inv H3; inv H2; simpl; auto. + - inv H4; inv H3; inv H2; simpl; auto. (* singleoffloat, floatofsingle *) - inv H4; simpl; auto. - inv H4; simpl; auto. @@ -1556,62 +1648,6 @@ Proof. exploit eval_condition_inj; eauto. intros EQ; rewrite EQ. destruct b; simpl; constructor. simpl; constructor. - (* select *) - - unfold eval_select. - inv H4; trivial. - inv H2; trivial. - inv H3; trivial; - try (destruct cond; simpl; trivial; fail). - destruct (eval_condition0 cond (Vptr _ _) m1) eqn:Hcond; trivial. - eassert (Hcond' : ((eval_condition0 cond (Vptr b2 (Ptrofs.add ofs1 (Ptrofs.repr delta)))) m2) = Some b). - * eapply eval_condition0_inj. - eapply Val.inject_ptr. - eassumption. - reflexivity. - assumption. - * rewrite Hcond'. constructor. - (* selectl *) - - unfold eval_selectl. - inv H4; trivial. - inv H2; trivial. - inv H3; trivial; - try (destruct cond; simpl; trivial; fail). - destruct (eval_condition0 cond (Vptr _ _) m1) eqn:Hcond; trivial. - eassert (Hcond' : ((eval_condition0 cond (Vptr b2 (Ptrofs.add ofs1 (Ptrofs.repr delta)))) m2) = Some b). - * eapply eval_condition0_inj. - eapply Val.inject_ptr. - eassumption. - reflexivity. - assumption. - * rewrite Hcond'. constructor. - (* selectf *) - - unfold eval_selectf. - inv H4; trivial. - inv H2; trivial. - inv H3; trivial; - try (destruct cond; simpl; trivial; fail). - destruct (eval_condition0 cond (Vptr _ _) m1) eqn:Hcond; trivial. - eassert (Hcond' : ((eval_condition0 cond (Vptr b2 (Ptrofs.add ofs1 (Ptrofs.repr delta)))) m2) = Some b). - * eapply eval_condition0_inj. - eapply Val.inject_ptr. - eassumption. - reflexivity. - assumption. - * rewrite Hcond'. constructor. - (* selectfs *) - - unfold eval_selectfs. - inv H4; trivial. - inv H2; trivial. - inv H3; trivial; - try (destruct cond; simpl; trivial; fail). - destruct (eval_condition0 cond (Vptr _ _) m1) eqn:Hcond; trivial. - eassert (Hcond' : ((eval_condition0 cond (Vptr b2 (Ptrofs.add ofs1 (Ptrofs.repr delta)))) m2) = Some b). - * eapply eval_condition0_inj. - eapply Val.inject_ptr. - eassumption. - reflexivity. - assumption. - * rewrite Hcond'. constructor. (* extfz *) - unfold extfz. @@ -1652,6 +1688,30 @@ Proof. simpl. destruct (Int.ltu _ _); trivial. simpl. trivial. + trivial. + + (* Osel *) + - apply Val.select_inject; trivial. + destruct (eval_condition0 c0 v2 m1) eqn:Hcond. + + right. + symmetry. + eapply eval_condition0_inj; eassumption. + + left. trivial. + + (* Oselimm *) + - apply Val.select_inject; trivial. + destruct (eval_condition0 _ _ _) eqn:Hcond. + + right. + symmetry. + eapply eval_condition0_inj; eassumption. + + left. trivial. + + (* Osellimm *) + - apply Val.select_inject; trivial. + destruct (eval_condition0 _ _ _) eqn:Hcond. + + right. + symmetry. + eapply eval_condition0_inj; eassumption. + + left. trivial. Qed. Lemma eval_addressing_inj: @@ -1674,6 +1734,27 @@ Proof. - apply Val.offset_ptr_inject; auto. Qed. +Lemma eval_addressing_inj_none: + forall addr sp1 vl1 sp2 vl2, + (forall id ofs, + In id (globals_addressing addr) -> + Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) -> + Val.inject f sp1 sp2 -> + Val.inject_list f vl1 vl2 -> + eval_addressing ge1 sp1 addr vl1 = None -> + eval_addressing ge2 sp2 addr vl2 = None. +Proof. + intros until vl2. intros Hglobal Hinjsp Hinjvl. + destruct addr; simpl in *. + 1,2: inv Hinjvl; trivial; + inv H0; trivial; + inv H2; trivial; + discriminate. + 2,3: inv Hinjvl; trivial; discriminate. + inv Hinjvl; trivial; inv H0; trivial; + inv H; trivial; discriminate. +Qed. + End EVAL_COMPAT. (** Compatibility of the evaluation functions with the ``is less defined'' relation over values. *) @@ -1780,6 +1861,24 @@ Proof. destruct H1 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. Qed. + +Lemma eval_addressing_lessdef_none: + forall sp addr vl1 vl2, + Val.lessdef_list vl1 vl2 -> + eval_addressing genv sp addr vl1 = None -> + eval_addressing genv sp addr vl2 = None. +Proof. + intros until vl2. intros Hlessdef Heval1. + destruct addr; simpl in *. + 1, 2, 4, 5: inv Hlessdef; trivial; + inv H0; trivial; + inv H2; trivial; + discriminate. + inv Hlessdef; trivial. + inv H0; trivial. + discriminate. +Qed. + End EVAL_LESSDEF. (** Compatibility of the evaluation functions with memory injections. *) @@ -1832,6 +1931,19 @@ Proof. econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. Qed. +Lemma eval_addressing_inject_none: + forall addr vl1 vl2, + Val.inject_list f vl1 vl2 -> + eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = None -> + eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = None. +Proof. + intros. + rewrite eval_shift_stack_addressing. + eapply eval_addressing_inj_none 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 -> diff --git a/mppa_k1c/Peephole.v b/mppa_k1c/Peephole.v index 7c8f65a8..0611fdda 100644 --- a/mppa_k1c/Peephole.v +++ b/mppa_k1c/Peephole.v @@ -2,6 +2,7 @@ Require Import Coqlib. Require Import Asmvliw. Require Import Values. Require Import Integers. +Require Import AST. Require Compopts. Definition gpreg_q_list : list gpreg_q := @@ -89,8 +90,8 @@ Fixpoint coalesce_mem (insns : list basic) : list basic := | None => h0 :: (coalesce_mem t0) end - | (PLoadRRO Pld_a rd0 ra0 ofs0), - (PLoadRRO Pld_a rd1 ra1 ofs1) => + | (PLoad (PLoadRRO TRAP Pld_a rd0 ra0 ofs0)), + (PLoad (PLoadRRO TRAP Pld_a rd1 ra1 ofs1)) => match gpreg_q_search rd0 rd1 with | Some rd0rd1 => let zofs0 := Ptrofs.signed ofs0 in @@ -100,8 +101,8 @@ Fixpoint coalesce_mem (insns : list basic) : list basic := if coalesce_octuples then match t1 with - | (PLoadRRO Pld_a rd2 ra2 ofs2) :: - (PLoadRRO Pld_a rd3 ra3 ofs3) :: t3 => + | (PLoad (PLoadRRO TRAP Pld_a rd2 ra2 ofs2)) :: + (PLoad (PLoadRRO TRAP Pld_a rd3 ra3 ofs3)) :: t3 => match gpreg_o_search rd0 rd1 rd2 rd3 with | Some octuple => let zofs2 := Ptrofs.signed ofs2 in diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index 15cb4c48..31180cea 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -12,14 +12,14 @@ Require Import Coqlib Errors AST Integers. Require Import Asmblock Axioms Memory Globalenvs. -Require Import Asmblockdeps Asmblockgenproof0. +Require Import Asmblockdeps Asmblockgenproof0 Asmblockprops. Require Peephole. Local Open Scope error_monad_scope. (** Oracle taking as input a basic block, returns a schedule expressed as a list of bundles *) -Axiom schedule: bblock -> list bblock. +Axiom schedule: bblock -> (list (list basic)) * option control. Extract Constant schedule => "PostpassSchedulingOracle.schedule". @@ -208,7 +208,8 @@ Proof. + apply IHlbb in EQ. assumption. Qed. - +Inductive is_concat : bblock -> list bblock -> Prop := + | mk_is_concat: forall tbb lbb, concat_all lbb = OK tbb -> is_concat tbb lbb. Definition verify_schedule (bb bb' : bblock) : res unit := match bblock_simub bb bb' with @@ -333,10 +334,49 @@ Proof. apply stick_header_concat_all. assumption. Qed. +Program Definition make_bblock_from_basics lb := + match lb with + | nil => Error (msg "PostpassScheduling.make_bblock_from_basics") + | b :: lb => OK {| header := nil; body := b::lb; exit := None |} + end. + +Fixpoint schedule_to_bblocks_nocontrol llb := + match llb with + | nil => OK nil + | lb :: llb => do bb <- make_bblock_from_basics lb; + do lbb <- schedule_to_bblocks_nocontrol llb; + OK (bb :: lbb) + end. + +Program Definition make_bblock_from_basics_and_control lb c := + match c with + | PExpand (Pbuiltin _ _ _) => Error (msg "PostpassScheduling.make_bblock_from_basics_and_control") + | PCtlFlow cf => OK {| header := nil; body := lb; exit := Some (PCtlFlow cf) |} + end. +Next Obligation. + apply wf_bblock_refl. constructor. + - right. discriminate. + - discriminate. +Qed. + +Fixpoint schedule_to_bblocks_wcontrol llb c := + match llb with + | nil => OK ((bblock_single_inst (PControl c)) :: nil) + | lb :: nil => do bb <- make_bblock_from_basics_and_control lb c; OK (bb :: nil) + | lb :: llb => do bb <- make_bblock_from_basics lb; + do lbb <- schedule_to_bblocks_wcontrol llb c; + OK (bb :: lbb) + end. +Definition schedule_to_bblocks (llb: list (list basic)) (oc: option control) : res (list bblock) := + match oc with + | None => schedule_to_bblocks_nocontrol llb + | Some c => schedule_to_bblocks_wcontrol llb c + end. -Definition do_schedule (bb: bblock) : list bblock := - if (Z.eqb (size bb) 1) then bb::nil else schedule bb. +Definition do_schedule (bb: bblock) : res (list bblock) := + if (Z.eqb (size bb) 1) then OK (bb::nil) + else match (schedule bb) with (llb, oc) => schedule_to_bblocks llb oc end. Definition verify_par_bblock (bb: bblock) : res unit := if (bblock_para_check bb) then OK tt else Error (msg "PostpassScheduling.verify_par_bblock"). @@ -350,7 +390,7 @@ Fixpoint verify_par (lbb: list bblock) := Definition verified_schedule_nob (bb : bblock) : res (list bblock) := let bb' := no_header bb in let bb'' := Peephole.optimize_bblock bb' in - let lbb := do_schedule bb'' in + do lbb <- do_schedule bb''; do tbb <- concat_all lbb; do sizecheck <- verify_size bb lbb; do schedcheck <- verify_schedule bb' tbb; @@ -363,7 +403,7 @@ Lemma verified_schedule_nob_size: Proof. intros. monadInv H. erewrite <- stick_header_code_size; eauto. apply verify_size_size. - destruct x0; try discriminate. assumption. + destruct x1; try discriminate. assumption. Qed. Lemma verified_schedule_nob_no_header_in_middle: @@ -382,7 +422,7 @@ Lemma verified_schedule_nob_header: /\ Forall (fun b => header b = nil) lbb. Proof. intros. split. - - monadInv H. unfold stick_header_code in EQ2. destruct (hd_error _); try discriminate. inv EQ2. + - monadInv H. unfold stick_header_code in EQ3. destruct (hd_error _); try discriminate. inv EQ3. simpl. reflexivity. - apply verified_schedule_nob_no_header_in_middle in H. assumption. Qed. @@ -427,29 +467,29 @@ Qed. Lemma verified_schedule_nob_correct: forall ge f bb lbb, verified_schedule_nob bb = OK lbb -> - exists tbb, - concat_all lbb = OK tbb + exists tbb, + is_concat tbb lbb /\ bblock_simu ge f bb tbb. Proof. intros. monadInv H. exploit stick_header_code_concat_all; eauto. intros (tbb & CONC & STH). - exists tbb. split; auto. - rewrite verify_schedule_no_header in EQ0. erewrite stick_header_verify_schedule in EQ0; eauto. - eapply bblock_simub_correct; eauto. unfold verify_schedule in EQ0. + exists tbb. split; auto. constructor; auto. + rewrite verify_schedule_no_header in EQ2. erewrite stick_header_verify_schedule in EQ2; eauto. + eapply bblock_simub_correct; eauto. unfold verify_schedule in EQ2. destruct (bblock_simub _ _); auto; try discriminate. Qed. Theorem verified_schedule_correct: forall ge f bb lbb, verified_schedule bb = OK lbb -> - exists tbb, - concat_all lbb = OK tbb + exists tbb, + is_concat tbb lbb /\ bblock_simu ge f bb tbb. Proof. intros. unfold verified_schedule in H. destruct (exit bb). destruct c. destruct i. all: try (eapply verified_schedule_nob_correct; eauto; fail). - inv H. eexists. split; simpl; auto. constructor; auto. + inv H. eexists. split; simpl; auto. constructor; auto. simpl; auto. constructor; auto. Qed. Lemma verified_schedule_builtin_idem: diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 7015fd5f..686979a6 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -15,186 +15,270 @@ type immediate = I32 of Integers.Int.int | I64 of Integers.Int64.int | Off of of type location = Reg of preg | Mem +type real_instruction = + (* ALU *) + | Addw | Andw | Compw | Mulw | Orw | Sbfw | Sbfxw | Sraw | Srlw | Sllw | Srsw | Rorw | Xorw + | Addd | Andd | Compd | Muld | Ord | Sbfd | Sbfxd | Srad | Srld | Slld | Srsd | Xord + | Nandw | Norw | Nxorw | Nandd | Nord | Nxord | Andnw | Ornw | Andnd | Ornd + | Maddw | Maddd | Msbfw | Msbfd | Cmoved + | Make | Nop | Extfz | Extfs | Insf + | Addxw | Addxd + (* LSU *) + | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq | Lo + | Sb | Sh | Sw | Sd | Sq | So + (* BCU *) + | Icall | Call | Cb | Igoto | Goto | Ret | Get | Set + (* FPU *) + | Fabsd | Fabsw | Fnegw | Fnegd + | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw + | Fmind | Fminw | Fmaxd | Fmaxw | Finvw + | Ffmaw | Ffmad | Ffmsw | Ffmsd + | Fnarrowdw | Fwidenlwd | Floatwz | Floatuwz | Floatdz | Floatudz | Fixedwz | Fixeduwz | Fixeddz | Fixedudz + | Fcompw | Fcompd + type ab_inst_rec = { - inst: string; (* name of the pseudo instruction *) + inst: real_instruction; write_locs : location list; read_locs : location list; + read_at_id : location list; (* Must be contained in read_locs *) + read_at_e1 : location list; (* idem *) imm : immediate option; is_control : bool; } -(** Asmvliw constructor to string functions *) +(** Asmvliw constructor to real instructions *) exception OpaqueInstruction -let arith_rr_str = function - | Pcvtl2w -> "Pcvtl2w" - | Pmv -> "Pmv" - | Pnegw -> "Pnegw" - | Pnegl -> "Pnegl" - | Psxwd -> "Psxwd" - | Pzxwd -> "Pzxwd" - | Pextfz(_,_) -> "Pextfz" - | Pextfs(_,_) -> "Pextfs" - | Pextfzl(_,_) -> "Pextfzl" - | Pextfsl(_,_) -> "Pextfsl" - | Pfabsw -> "Pfabsw" - | Pfabsd -> "Pfabsd" - | Pfnegw -> "Pfnegw" - | Pfnegd -> "Pfnegd" - | Pfnarrowdw -> "Pfnarrowdw" - | Pfwidenlwd -> "Pfwidenlwd" - | Pfloatwrnsz -> "Pfloatwrnsz" - | Pfloatuwrnsz -> "Pfloatuwrnsz" - | Pfloatudrnsz -> "Pfloatudrnsz" - | Pfloatdrnsz -> "Pfloatdrnsz" - | Pfixedwrzz -> "Pfixedwrzz" - | Pfixeduwrzz -> "Pfixeduwrzz" - | Pfixeddrzz -> "Pfixeddrzz" - | Pfixedudrzz -> "Pfixedudrzz" - | Pfixeddrzz_i32 -> "Pfixeddrzz_i32" - | Pfixedudrzz_i32 -> "Pfixedudrzz_i32" - -let arith_rrr_str = function - | Pcompw it -> "Pcompw" - | Pcompl it -> "Pcompl" - | Pfcompw ft -> "Pfcompw" - | Pfcompl ft -> "Pfcompl" - | Paddw -> "Paddw" - | Psubw -> "Psubw" - | Pmulw -> "Pmulw" - | Pandw -> "Pandw" - | Pnandw -> "Pnandw" - | Porw -> "Porw" - | Pnorw -> "Pnorw" - | Pxorw -> "Pxorw" - | Pnxorw -> "Pnxorw" - | Pandnw -> "Pandnw" - | Pornw -> "Pornw" - | Psraw -> "Psraw" - | Psrlw -> "Psrlw" - | Psrxw -> "Psrxw" - | Psllw -> "Psllw" - | Paddl -> "Paddl" - | Psubl -> "Psubl" - | Pandl -> "Pandl" - | Pnandl -> "Pnandl" - | Porl -> "Porl" - | Pnorl -> "Pnorl" - | Pxorl -> "Pxorl" - | Pnxorl -> "Pnxorl" - | Pandnl -> "Pandnl" - | Pornl -> "Pornl" - | Pmull -> "Pmull" - | Pslll -> "Pslll" - | Psrll -> "Psrll" - | Psrxl -> "Psrxl" - | Psral -> "Psral" - | Pfaddd -> "Pfaddd" - | Pfaddw -> "Pfaddw" - | Pfsbfd -> "Pfsbfd" - | Pfsbfw -> "Pfsbfw" - | Pfmuld -> "Pfmuld" - | Pfmulw -> "Pfmulw" - -let arith_rri32_str = function - | Pcompiw it -> "Pcompiw" - | Paddiw -> "Paddiw" - | Pmuliw -> "Pmuliw" - | Pandiw -> "Pandiw" - | Pnandiw -> "Pnandiw" - | Poriw -> "Poriw" - | Pnoriw -> "Pnoriw" - | Pxoriw -> "Pxoriw" - | Pnxoriw -> "Pnxoriw" - | Pandniw -> "Pandniw" - | Porniw -> "Porniw" - | Psraiw -> "Psraiw" - | Psrxiw -> "Psrxiw" - | Psrliw -> "Psrliw" - | Pslliw -> "Pslliw" - | Proriw -> "Proriw" - | Psllil -> "Psllil" - | Psrlil -> "Psrlil" - | Psrail -> "Psrail" - | Psrxil -> "Psrxil" - -let arith_rri64_str = function - | Pcompil it -> "Pcompil" - | Paddil -> "Paddil" - | Pmulil -> "Pmulil" - | Pandil -> "Pandil" - | Pnandil -> "Pnandil" - | Poril -> "Poril" - | Pnoril -> "Pnoril" - | Pxoril -> "Pxoril" - | Pnxoril -> "Pnxoril" - | Pandnil -> "Pandnil" - | Pornil -> "Pornil" - - -let arith_arr_str = function - | Pinsf (_, _) -> "Pinsf" - | Pinsfl (_, _) -> "Pinsfl" - -let arith_arrr_str = function - | Pmaddw -> "Pmaddw" - | Pmaddl -> "Pmaddl" - | Pcmove _ -> "Pcmove" - | Pcmoveu _ -> "Pcmoveu" - -let arith_ri32_str = "Pmake" - -let arith_ri64_str = "Pmakel" - -let arith_rf32_str = "Pmakefs" - -let arith_rf64_str = "Pmakef" - -let store_str = function - | Psb -> "Psb" - | Psh -> "Psh" - | Psw -> "Psw" - | Psw_a -> "Psw_a" - | Psd -> "Psd" - | Psd_a -> "Psd_a" - | Pfss -> "Pfss" - | Pfsd -> "Pfsd" - -let load_str = function - | Plb -> "Plb" - | Plbu -> "Plbu" - | Plh -> "Plh" - | Plhu -> "Plhu" - | Plw -> "Plw" - | Plw_a -> "Plw_a" - | Pld -> "Pld" - | Pld_a -> "Pld_a" - | Pfls -> "Pfls" - | Pfld -> "Pfld" - -let set_str = "Pset" -let get_str = "Pget" - -let arith_rri32_rec i rd rs imm32 = { inst = arith_rri32_str i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm32; is_control = false } - -let arith_rri64_rec i rd rs imm64 = { inst = arith_rri64_str i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm64; is_control = false } - -let arith_rrr_rec i rd rs1 rs2 = { inst = arith_rrr_str i; write_locs = [Reg rd]; read_locs = [Reg rs1; Reg rs2]; imm = None; is_control = false} - -let arith_arri32_rec i rd rs imm32 = { inst = "Pmaddiw"; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm32; is_control = false } - -let arith_arri64_rec i rd rs imm64 = { inst = "Pmaddil"; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm64; is_control = false } - -let arith_arr_rec i rd rs = { inst = arith_arr_str i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = None; is_control = false} - -let arith_arrr_rec i rd rs1 rs2 = { inst = arith_arrr_str i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs1; Reg rs2]; imm = None; is_control = false} - -let arith_rr_rec i rd rs = { inst = arith_rr_str i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = None; is_control = false} +let arith_rr_real = function + | Pcvtl2w -> Addw + | Pmv -> Addd + | Pnegw -> Sbfw + | Pnegl -> Sbfd + | Psxwd -> Extfs + | Pzxwd -> Extfz + | Pextfz(_,_) -> Extfz + | Pextfs(_,_) -> Extfs + | Pextfzl(_,_) -> Extfz + | Pextfsl(_,_) -> Extfs + | Pfabsw -> Fabsw + | Pfabsd -> Fabsd + | Pfnegw -> Fnegw + | Pfnegd -> Fnegd + | Pfinvw -> Finvw + | Pfnarrowdw -> Fnarrowdw + | Pfwidenlwd -> Fwidenlwd + | Pfloatwrnsz -> Floatwz + | Pfloatuwrnsz -> Floatuwz + | Pfloatudrnsz -> Floatudz + | Pfloatdrnsz -> Floatdz + | Pfixedwrzz -> Fixedwz + | Pfixeduwrzz -> Fixeduwz + | Pfixeddrzz -> Fixeddz + | Pfixedudrzz -> Fixedudz + | Pfixeddrzz_i32 -> Fixeddz + | Pfixedudrzz_i32 -> Fixedudz + +let arith_rrr_real = function + | Pcompw it -> Compw + | Pcompl it -> Compd + | Pfcompw ft -> Fcompw + | Pfcompl ft -> Fcompd + | Paddw -> Addw + | Paddxw _ -> Addxw + | Psubw -> Sbfw + | Prevsubxw _ -> Sbfxw + | Pmulw -> Mulw + | Pandw -> Andw + | Pnandw -> Nandw + | Porw -> Orw + | Pnorw -> Norw + | Pxorw -> Xorw + | Pnxorw -> Nxorw + | Pandnw -> Andnw + | Pornw -> Ornw + | Psraw -> Sraw + | Psrlw -> Srlw + | Psrxw -> Srsw + | Psllw -> Sllw + | Paddl -> Addd + | Paddxl _ -> Addxd + | Psubl -> Sbfd + | Prevsubxl _ -> Sbfxd + | Pandl -> Andd + | Pnandl -> Nandd + | Porl -> Ord + | Pnorl -> Nord + | Pxorl -> Xord + | Pnxorl -> Nxord + | Pandnl -> Andnd + | Pornl -> Ornd + | Pmull -> Muld + | Pslll -> Slld + | Psrll -> Srld + | Psrxl -> Srsd + | Psral -> Srad + | Pfaddd -> Faddd + | Pfaddw -> Faddw + | Pfsbfd -> Fsbfd + | Pfsbfw -> Fsbfw + | Pfmuld -> Fmuld + | Pfmulw -> Fmulw + | Pfmind -> Fmind + | Pfminw -> Fminw + | Pfmaxd -> Fmaxd + | Pfmaxw -> Fmaxw + +let arith_rri32_real = function + | Pcompiw it -> Compw + | Paddiw -> Addw + | Paddxiw _ -> Addxw + | Prevsubiw -> Sbfw + | Prevsubxiw _ -> Sbfxw + | Pmuliw -> Mulw + | Pandiw -> Andw + | Pnandiw -> Nandw + | Poriw -> Orw + | Pnoriw -> Norw + | Pxoriw -> Xorw + | Pnxoriw -> Nxorw + | Pandniw -> Andnw + | Porniw -> Ornw + | Psraiw -> Sraw + | Psrxiw -> Srsw + | Psrliw -> Srlw + | Pslliw -> Sllw + | Proriw -> Rorw + | Psllil -> Slld + | Psrlil -> Srld + | Psrail -> Srad + | Psrxil -> Srsd + +let arith_rri64_real = function + | Pcompil it -> Compd + | Paddil -> Addd + | Prevsubil -> Sbfd + | Paddxil _ -> Addxd + | Prevsubxil _ -> Sbfxd + | Pmulil -> Muld + | Pandil -> Andd + | Pnandil -> Nandd + | Poril -> Ord + | Pnoril -> Nord + | Pxoril -> Xord + | Pnxoril -> Nxord + | Pandnil -> Andnd + | Pornil -> Ornd + + +let arith_arr_real = function + | Pinsf (_, _) -> Insf + | Pinsfl (_, _) -> Insf + +let arith_arrr_real = function + | Pfmaddfw -> Ffmaw + | Pfmaddfl -> Ffmad + | Pfmsubfw -> Ffmsw + | Pfmsubfl -> Ffmsd + | Pmaddw -> Maddw + | Pmaddl -> Maddd + | Pmsubw -> Msbfw + | Pmsubl -> Msbfd + | Pcmove _ -> Cmoved + | Pcmoveu _ -> Cmoved + +let arith_arri32_real = function + | Pmaddiw -> Maddw + | Pcmoveiw _ -> Cmoved + | Pcmoveuiw _ -> Cmoved + +let arith_arri64_real = function + | Pmaddil -> Maddd + | Pcmoveil _ -> Cmoved + | Pcmoveuil _ -> Cmoved + +let arith_ri32_real = Make + +let arith_ri64_real = Make + +let arith_rf32_real = Make + +let arith_rf64_real = Make + +let store_real = function + | Psb -> Sb + | Psh -> Sh + | Psw -> Sw + | Psw_a -> Sw + | Psd -> Sd + | Psd_a -> Sd + | Pfss -> Sw + | Pfsd -> Sd + +let load_real = function + | Plb -> Lbs + | Plbu -> Lbz + | Plh -> Lhs + | Plhu -> Lhz + | Plw -> Lws + | Plw_a -> Lws + | Pld -> Ld + | Pld_a -> Ld + | Pfls -> Lws + | Pfld -> Ld + +let set_real = Set +let get_real = Get +let nop_real = Nop +let loadsymbol_real = Make +let loadqrro_real = Lq +let loadorro_real = Lo +let storeqrro_real = Sq +let storeorro_real = So + +let ret_real = Ret +let call_real = Call +let icall_real = Icall +let goto_real = Goto +let igoto_real = Igoto +let jl_real = Goto +let cb_real = Cb +let cbu_real = Cb + +let arith_rri32_rec i rd rs imm32 = { inst = arith_rri32_real i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm32; is_control = false; + read_at_id = []; read_at_e1 = [] } + +let arith_rri64_rec i rd rs imm64 = { inst = arith_rri64_real i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm64; is_control = false; + read_at_id = []; read_at_e1 = [] } + +let arith_rrr_rec i rd rs1 rs2 = { inst = arith_rrr_real i; write_locs = [Reg rd]; read_locs = [Reg rs1; Reg rs2]; imm = None; is_control = false; + read_at_id = []; read_at_e1 = [] } + +let arith_arri32_rec i rd rs imm32 = + let rae1 = match i with Pmaddiw -> [Reg rd] | _ -> [] + in { inst = arith_arri32_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm32; is_control = false; + read_at_id = [] ; read_at_e1 = rae1 } + +let arith_arri64_rec i rd rs imm64 = + let rae1 = match i with Pmaddil -> [Reg rd] | _ -> [] + in { inst = arith_arri64_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm64; is_control = false; + read_at_id = []; read_at_e1 = rae1 } + +let arith_arr_rec i rd rs = { inst = arith_arr_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = None; is_control = false; + read_at_id = []; read_at_e1 = [] } + +let arith_arrr_rec i rd rs1 rs2 = + let rae1 = match i with Pmaddl | Pmaddw | Pmsubl | Pmsubw -> [Reg rd] | _ -> [] + in { inst = arith_arrr_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs1; Reg rs2]; imm = None; is_control = false; + read_at_id = []; read_at_e1 = rae1 } + +let arith_rr_rec i rd rs = { inst = arith_rr_real i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = None; is_control = false; + read_at_id = []; read_at_e1 = [] } let arith_r_rec i rd = match i with (* For Ploadsymbol, writing the highest integer since we do not know how many bits does a symbol have *) - | Ploadsymbol (id, ofs) -> { inst = "Ploadsymbol"; write_locs = [Reg rd]; read_locs = []; imm = Some (I64 Integers.Int64.max_signed); is_control = false} + | Ploadsymbol (id, ofs) -> { inst = loadsymbol_real; write_locs = [Reg rd]; read_locs = []; imm = Some (I64 Integers.Int64.max_signed); + is_control = false; read_at_id = []; read_at_e1 = [] } let arith_rec i = match i with @@ -203,48 +287,57 @@ let arith_rec i = | PArithRRR (i, rd, rs1, rs2) -> arith_rrr_rec i (IR rd) (IR rs1) (IR rs2) | PArithARR (i, rd, rs) -> arith_arr_rec i (IR rd) (IR rs) (* Seems like single constant constructor types are elided *) - | PArithARRI32 ((* i,*) rd, rs, imm32) -> arith_arri32_rec () (IR rd) (IR rs) (Some (I32 imm32)) - | PArithARRI64 ((* i,*) rd, rs, imm64) -> arith_arri64_rec () (IR rd) (IR rs) (Some (I64 imm64)) + | PArithARRI32 (i, rd, rs, imm32) -> arith_arri32_rec i (IR rd) (IR rs) (Some (I32 imm32)) + | PArithARRI64 (i, rd, rs, imm64) -> arith_arri64_rec i (IR rd) (IR rs) (Some (I64 imm64)) | PArithARRR (i, rd, rs1, rs2) -> arith_arrr_rec i (IR rd) (IR rs1) (IR rs2) - | PArithRI32 (rd, imm32) -> { inst = arith_ri32_str; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I32 imm32)) ; is_control = false} - | PArithRI64 (rd, imm64) -> { inst = arith_ri64_str; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I64 imm64)) ; is_control = false} - | PArithRF32 (rd, f) -> { inst = arith_rf32_str; write_locs = [Reg (IR rd)]; read_locs = []; - imm = (Some (I32 (Floats.Float32.to_bits f))); is_control = false} - | PArithRF64 (rd, f) -> { inst = arith_rf64_str; write_locs = [Reg (IR rd)]; read_locs = []; - imm = (Some (I64 (Floats.Float.to_bits f))); is_control = false} + | PArithRI32 (rd, imm32) -> { inst = arith_ri32_real; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I32 imm32)) ; is_control = false; + read_at_id = []; read_at_e1 = [] } + | PArithRI64 (rd, imm64) -> { inst = arith_ri64_real; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I64 imm64)) ; is_control = false; + read_at_id = []; read_at_e1 = [] } + | PArithRF32 (rd, f) -> { inst = arith_rf32_real; write_locs = [Reg (IR rd)]; read_locs = []; + imm = (Some (I32 (Floats.Float32.to_bits f))); is_control = false; read_at_id = []; read_at_e1 = []} + | PArithRF64 (rd, f) -> { inst = arith_rf64_real; write_locs = [Reg (IR rd)]; read_locs = []; + imm = (Some (I64 (Floats.Float.to_bits f))); is_control = false; read_at_id = []; read_at_e1 = []} | PArithRR (i, rd, rs) -> arith_rr_rec i (IR rd) (IR rs) | PArithR (i, rd) -> arith_r_rec i (IR rd) let load_rec i = match i with - | PLoadRRO (i, rs1, rs2, imm) -> - { inst = load_str i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2)]; imm = (Some (Off imm)) ; is_control = false} + | PLoadRRO (trap, i, rs1, rs2, imm) -> + { inst = load_real i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2)]; imm = (Some (Off imm)) ; is_control = false; + read_at_id = []; read_at_e1 = [] } | PLoadQRRO(rs, ra, imm) -> let (rs0, rs1) = gpreg_q_expand rs in - { inst = "Plq"; write_locs = [Reg (IR rs0); Reg (IR rs1)]; read_locs = [Mem; Reg (IR ra)]; imm = (Some (Off imm)) ; is_control = false} + { inst = loadqrro_real; write_locs = [Reg (IR rs0); Reg (IR rs1)]; read_locs = [Mem; Reg (IR ra)]; imm = (Some (Off imm)) ; is_control = false; + read_at_id = []; read_at_e1 = [] } | PLoadORRO(rs, ra, imm) -> let (((rs0, rs1), rs2), rs3) = gpreg_o_expand rs in - { inst = "Plo"; write_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3)]; read_locs = [Mem; Reg (IR ra)]; imm = (Some (Off imm)) ; is_control = false} - | PLoadRRR (i, rs1, rs2, rs3) | PLoadRRRXS (i, rs1, rs2, rs3) -> - { inst = load_str i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2); Reg (IR rs3)]; imm = None ; is_control = false} + { inst = loadorro_real; write_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3)]; read_locs = [Mem; Reg (IR ra)]; + imm = (Some (Off imm)) ; is_control = false; read_at_id = []; read_at_e1 = []} + | PLoadRRR (trap, i, rs1, rs2, rs3) | PLoadRRRXS (trap, i, rs1, rs2, rs3) -> + { inst = load_real i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2); Reg (IR rs3)]; imm = None ; is_control = false; + read_at_id = []; read_at_e1 = [] } let store_rec i = match i with - | PStoreRRO (i, rs1, rs2, imm) -> - { inst = store_str i; write_locs = [Mem]; read_locs = [Reg (IR rs1); Reg (IR rs2)]; imm = (Some (Off imm)) - ; is_control = false} + | PStoreRRO (i, rs, ra, imm) -> + { inst = store_real i; write_locs = [Mem]; read_locs = [Reg (IR rs); Reg (IR ra)]; imm = (Some (Off imm)); + read_at_id = []; read_at_e1 = [Reg (IR rs)] ; is_control = false} | PStoreQRRO (rs, ra, imm) -> let (rs0, rs1) = gpreg_q_expand rs in - { inst = "Psq"; write_locs = [Mem]; read_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR ra)]; imm = (Some (Off imm)) - ; is_control = false} + { inst = storeqrro_real; write_locs = [Mem]; read_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR ra)]; imm = (Some (Off imm)); + read_at_id = []; read_at_e1 = [Reg (IR rs0); Reg (IR rs1)] ; is_control = false} | PStoreORRO (rs, ra, imm) -> let (((rs0, rs1), rs2), rs3) = gpreg_o_expand rs in - { inst = "Pso"; write_locs = [Mem]; read_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3); Reg (IR ra)]; imm = (Some (Off imm)) - ; is_control = false} - | PStoreRRR (i, rs1, rs2, rs3) | PStoreRRRXS (i, rs1, rs2, rs3) -> { inst = store_str i; write_locs = [Mem]; read_locs = [Reg (IR rs1); Reg (IR rs2); Reg (IR rs3)]; imm = None - ; is_control = false} + { inst = storeorro_real; write_locs = [Mem]; read_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3); Reg (IR ra)]; + imm = (Some (Off imm)); read_at_id = []; read_at_e1 = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3)]; is_control = false} + | PStoreRRR (i, rs, ra1, ra2) | PStoreRRRXS (i, rs, ra1, ra2) -> + { inst = store_real i; write_locs = [Mem]; read_locs = [Reg (IR rs); Reg (IR ra1); Reg (IR ra2)]; imm = None; + read_at_id = []; read_at_e1 = [Reg (IR rs)]; is_control = false} -let get_rec (rd:gpreg) rs = { inst = get_str; write_locs = [Reg (IR rd)]; read_locs = [Reg rs]; imm = None; is_control = false } +let get_rec (rd:gpreg) rs = { inst = get_real; write_locs = [Reg (IR rd)]; read_locs = [Reg rs]; imm = None; is_control = false; + read_at_id = []; read_at_e1 = [] } -let set_rec rd (rs:gpreg) = { inst = set_str; write_locs = [Reg rd]; read_locs = [Reg (IR rs)]; imm = None; is_control = false } +let set_rec rd (rs:gpreg) = { inst = set_real; write_locs = [Reg rd]; read_locs = [Reg (IR rs)]; imm = None; is_control = false; + read_at_id = [Reg (IR rs)]; read_at_e1 = [] } let basic_rec i = match i with @@ -255,21 +348,25 @@ let basic_rec i = | Pfreeframe (_, _) -> raise OpaqueInstruction | Pget (rd, rs) -> get_rec rd rs | Pset (rd, rs) -> set_rec rd rs - | Pnop -> { inst = "nop"; write_locs = []; read_locs = []; imm = None ; is_control = false} + | Pnop -> { inst = nop_real; write_locs = []; read_locs = []; imm = None ; is_control = false; read_at_id = []; read_at_e1 = []} let expand_rec = function | Pbuiltin _ -> raise OpaqueInstruction let ctl_flow_rec = function - | Pret -> { inst = "Pret"; write_locs = []; read_locs = [Reg RA]; imm = None ; is_control = true} - | Pcall lbl -> { inst = "Pcall"; write_locs = [Reg RA]; read_locs = []; imm = None ; is_control = true} - | Picall r -> { inst = "Picall"; write_locs = [Reg RA]; read_locs = [Reg (IR r)]; imm = None; is_control = true} - | Pgoto lbl -> { inst = "Pcall"; write_locs = []; read_locs = []; imm = None ; is_control = true} - | Pigoto r -> { inst = "Pigoto"; write_locs = []; read_locs = [Reg (IR r)]; imm = None ; is_control = true} - | Pj_l lbl -> { inst = "Pj_l"; write_locs = []; read_locs = []; imm = None ; is_control = true} - | Pcb (bt, rs, lbl) -> { inst = "Pcb"; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true} - | Pcbu (bt, rs, lbl) -> { inst = "Pcbu"; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true} - | Pjumptable (r, _) -> { inst = "Pjumptable"; write_locs = [Reg (IR GPR62); Reg (IR GPR63)]; read_locs = [Reg (IR r)]; imm = None ; is_control = true} + | Pret -> { inst = ret_real; write_locs = []; read_locs = [Reg RA]; imm = None ; is_control = true; read_at_id = [Reg RA]; read_at_e1 = []} + | Pcall lbl -> { inst = call_real; write_locs = [Reg RA]; read_locs = []; imm = None ; is_control = true; read_at_id = []; read_at_e1 = []} + | Picall r -> { inst = icall_real; write_locs = [Reg RA]; read_locs = [Reg (IR r)]; imm = None; is_control = true; + read_at_id = [Reg (IR r)]; read_at_e1 = [] } + | Pgoto lbl -> { inst = goto_real; write_locs = []; read_locs = []; imm = None ; is_control = true; read_at_id = []; read_at_e1 = []} + | Pigoto r -> { inst = igoto_real; write_locs = []; read_locs = [Reg (IR r)]; imm = None ; is_control = true; + read_at_id = [Reg (IR r)]; read_at_e1 = [] } + | Pj_l lbl -> { inst = goto_real; write_locs = []; read_locs = []; imm = None ; is_control = true; read_at_id = []; read_at_e1 = []} + | Pcb (bt, rs, lbl) -> { inst = cb_real; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true; + read_at_id = [Reg (IR rs)]; read_at_e1 = [] } + | Pcbu (bt, rs, lbl) -> { inst = cbu_real; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true; + read_at_id = [Reg (IR rs)]; read_at_e1 = [] } + | Pjumptable (r, _) -> raise OpaqueInstruction (* { inst = "Pjumptable"; write_locs = [Reg (IR GPR62); Reg (IR GPR63)]; read_locs = [Reg (IR r)]; imm = None ; is_control = true} *) let control_rec i = match i with @@ -294,6 +391,8 @@ let instruction_recs bb = (basic_recs bb.body) @ (exit_rec bb.exit) type inst_info = { write_locs : location list; read_locs : location list; + reads_at_id : bool; + reads_at_e1 : bool; is_control : bool; usage: int array; (* resources consumed by the instruction *) latency: int; @@ -343,7 +442,9 @@ let encode_imm (imm:int64) = else failwith @@ sprintf "encode_imm: integer too big! (%Ld)" imm (** Resources *) -let resource_names = ["ISSUE"; "TINY"; "LITE"; "ALU"; "LSU"; "MAU"; "BCU"; "ACC"; "DATA"; "TCA"; "BRE"; "BRO"; "NOP"] +type rname = Rissue | Rtiny | Rlite | Rfull | Rlsu | Rmau | Rbcu | Rtca | Rauxr | Rauxw | Rcrrp | Rcrwl | Rcrwh | Rnop + +let resource_names = [Rissue; Rtiny; Rlite; Rfull; Rlsu; Rmau; Rbcu; Rtca; Rauxr; Rauxw; Rcrrp; Rcrwl; Rcrwh; Rnop] let rec find_index elt l = match l with @@ -355,231 +456,147 @@ let resource_id resource : int = find_index resource resource_names let resource_bound resource : int = match resource with - | "ISSUE" -> 8 - | "TINY" -> 4 - | "LITE" -> 2 - | "ALU" -> 1 - | "LSU" -> 1 - | "MAU" -> 1 - | "BCU" -> 1 - | "ACC" -> 1 - | "DATA" -> 1 - | "TCA" -> 1 - | "BRE" -> 1 - | "BRO" -> 1 - | "NOP" -> 4 - | _ -> raise Not_found + | Rissue -> 8 + | Rtiny -> 4 + | Rlite -> 2 + | Rfull -> 1 + | Rlsu -> 1 + | Rmau -> 1 + | Rbcu -> 1 + | Rtca -> 1 + | Rauxr -> 1 + | Rauxw -> 1 + | Rcrrp -> 1 + | Rcrwl -> 1 + | Rcrwh -> 1 + | Rnop -> 4 let resource_bounds : int array = Array.of_list (List.map resource_bound resource_names) (** Reservation tables *) -let alu_tiny : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let alu_tiny_x : int array = let resmap = fun r -> match r with - | "ISSUE" -> 2 | "TINY" -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let alu_tiny_y : int array = let resmap = fun r -> match r with - | "ISSUE" -> 3 | "TINY" -> 1 | _ -> 0 +let alu_full : int array = let resmap = fun r -> match r with + | Rissue -> 1 | Rtiny -> 1 | Rlite -> 1 | Rfull -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let alu_lite : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | "LITE" -> 1 | _ -> 0 + | Rissue -> 1 | Rtiny -> 1 | Rlite -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let alu_lite_x : int array = let resmap = fun r -> match r with - | "ISSUE" -> 2 | "TINY" -> 1 | "LITE" -> 1 | _ -> 0 + | Rissue -> 2 | Rtiny -> 1 | Rlite -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let alu_full : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | "LITE" -> 1 | "ALU" -> 1 | _ -> 0 +let alu_lite_y : int array = let resmap = fun r -> match r with + | Rissue -> 3 | Rtiny -> 1 | Rlite -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let alu_nop : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "NOP" -> 1 | _ -> 0 + | Rissue -> 1 | Rnop -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let mau : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | "MAU" -> 1 | _ -> 0 +let alu_tiny : int array = let resmap = fun r -> match r with + | Rissue -> 1 | Rtiny -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let mau_x : int array = let resmap = fun r -> match r with - | "ISSUE" -> 2 | "TINY" -> 1 | "MAU" -> 1 | _ -> 0 +let alu_tiny_x : int array = let resmap = fun r -> match r with + | Rissue -> 2 | Rtiny -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let mau_y : int array = let resmap = fun r -> match r with - | "ISSUE" -> 3 | "TINY" -> 1 | "MAU" -> 1 | _ -> 0 +let alu_tiny_y : int array = let resmap = fun r -> match r with + | Rissue -> 3 | Rtiny -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let bcu : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "BCU" -> 1 | _ -> 0 + | Rissue -> 1 | Rbcu -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let bcu_tiny_tiny_mau_xnop : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 2 | "MAU" -> 1 | "BCU" -> 1 | "NOP" -> 4 | _ -> 0 + | Rissue -> 1 | Rtiny -> 2 | Rmau -> 1 | Rbcu -> 1 | Rnop -> 4 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let lsu_acc : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | "LSU" -> 1 | "ACC" -> 1 | _ -> 0 +let lsu_auxr : int array = let resmap = fun r -> match r with + | Rissue -> 1 | Rtiny -> 1 | Rlsu -> 1 | Rauxr -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let lsu_acc_x : int array = let resmap = fun r -> match r with - | "ISSUE" -> 2 | "TINY" -> 1 | "LSU" -> 1 | "ACC" -> 1 | _ -> 0 +let lsu_auxr_x : int array = let resmap = fun r -> match r with + | Rissue -> 2 | Rtiny -> 1 | Rlsu -> 1 | Rauxr -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let lsu_acc_y : int array = let resmap = fun r -> match r with - | "ISSUE" -> 3 | "TINY" -> 1 | "LSU" -> 1 | "ACC" -> 1 | _ -> 0 +let lsu_auxr_y : int array = let resmap = fun r -> match r with + | Rissue -> 3 | Rtiny -> 1 | Rlsu -> 1 | Rauxr -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let lsu_data : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | "LSU" -> 1 | "DATA" -> 1 | _ -> 0 +let lsu_auxw : int array = let resmap = fun r -> match r with + | Rissue -> 1 | Rtiny -> 1 | Rlsu -> 1 | Rauxw -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let lsu_data_x : int array = let resmap = fun r -> match r with - | "ISSUE" -> 2 | "TINY" -> 1 | "LSU" -> 1 | "DATA" -> 1 | _ -> 0 +let lsu_auxw_x : int array = let resmap = fun r -> match r with + | Rissue -> 2 | Rtiny -> 1 | Rlsu -> 1 | Rauxw -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let lsu_data_y : int array = let resmap = fun r -> match r with - | "ISSUE" -> 3 | "TINY" -> 1 | "LSU" -> 1 | "DATA" -> 1 | _ -> 0 +let lsu_auxw_y : int array = let resmap = fun r -> match r with + | Rissue -> 3 | Rtiny -> 1 | Rlsu -> 1 | Rauxw -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -(** Real instructions *) +let mau : int array = let resmap = fun r -> match r with + | Rissue -> 1 | Rtiny -> 1 | Rmau -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) -type real_instruction = - (* ALU *) - | Addw | Andw | Compw | Mulw | Orw | Sbfw | Sraw | Srlw | Sllw | Srsw | Rorw | Xorw - | Addd | Andd | Compd | Muld | Ord | Sbfd | Srad | Srld | Slld | Srsd | Xord - | Nandw | Norw | Nxorw | Nandd | Nord | Nxord | Andnw | Ornw | Andnd | Ornd - | Maddw | Maddd | Cmoved - | Make | Nop | Extfz | Extfs | Insf - (* LSU *) - | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq | Lo - | Sb | Sh | Sw | Sd | Sq | So - (* BCU *) - | Icall | Call | Cb | Igoto | Goto | Ret | Get | Set - (* FPU *) - | Fabsd | Fabsw | Fnegw | Fnegd - | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw - | Fnarrowdw | Fwidenlwd | Floatwz | Floatuwz | Floatdz | Floatudz | Fixedwz | Fixeduwz | Fixeddz | Fixedudz - | Fcompw | Fcompd +let mau_x : int array = let resmap = fun r -> match r with + | Rissue -> 2 | Rtiny -> 1 | Rmau -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let mau_y : int array = let resmap = fun r -> match r with + | Rissue -> 3 | Rtiny -> 1 | Rmau -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let mau_auxr : int array = let resmap = fun r -> match r with + | Rissue -> 1 | Rtiny -> 1 | Rmau -> 1 | Rauxr -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let mau_auxr_x : int array = let resmap = fun r -> match r with + | Rissue -> 2 | Rtiny -> 1 | Rmau -> 1 | Rauxr -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let mau_auxr_y : int array = let resmap = fun r -> match r with + | Rissue -> 3 | Rtiny -> 1 | Rmau -> 1 | Rauxr -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +(** Real instructions *) -let ab_inst_to_real = function - | "Paddw" | "Paddiw" | "Pcvtl2w" -> Addw - | "Paddl" | "Paddil" | "Pmv" | "Pmvw2l" -> Addd - | "Pandw" | "Pandiw" -> Andw - | "Pnandw" | "Pnandiw" -> Nandw - | "Pandl" | "Pandil" -> Andd - | "Pnandl" | "Pnandil" -> Nandd - | "Pcompw" | "Pcompiw" -> Compw - | "Pcompl" | "Pcompil" -> Compd - | "Pfcompw" -> Fcompw - | "Pfcompl" -> Fcompd - | "Pmulw" | "Pmuliw" -> Mulw - | "Pmull" | "Pmulil" -> Muld - | "Porw" | "Poriw" -> Orw - | "Pnorw" | "Pnoriw" -> Norw - | "Porl" | "Poril" -> Ord - | "Pnorl" | "Pnoril" -> Nord - | "Psubw" | "Pnegw" -> Sbfw - | "Psubl" | "Pnegl" -> Sbfd - | "Psraw" | "Psraiw" -> Sraw - | "Psral" | "Psrail" -> Srad - | "Psrxw" | "Psrxiw" -> Srsw - | "Psrxl" | "Psrxil" -> Srsd - | "Psrlw" | "Psrliw" -> Srlw - | "Psrll" | "Psrlil" -> Srld - | "Psllw" | "Pslliw" -> Sllw - | "Proriw" -> Rorw - | "Pmaddw" | "Pmaddiw" -> Maddw - | "Pslll" | "Psllil" -> Slld - | "Pxorw" | "Pxoriw" -> Xorw - | "Pnxorw" | "Pnxoriw" -> Nxorw - | "Pandnw" | "Pandniw" -> Andnw - | "Pornw" | "Porniw" -> Ornw - | "Pxorl" | "Pxoril" -> Xord - | "Pnxorl" | "Pnxoril" -> Nxord - | "Pandnl" | "Pandnil" -> Andnd - | "Pornl" | "Pornil" -> Ornd - | "Pmaddl" -> Maddd - | "Pmake" | "Pmakel" | "Pmakefs" | "Pmakef" | "Ploadsymbol" -> Make - | "Pnop" | "Pcvtw2l" -> Nop - | "Pextfz" | "Pextfzl" | "Pzxwd" -> Extfz - | "Pextfs" | "Pextfsl" | "Psxwd" -> Extfs - | "Pinsf" | "Pinsfl" -> Insf - | "Pfnarrowdw" -> Fnarrowdw - | "Pfwidenlwd" -> Fwidenlwd - | "Pfloatwrnsz" -> Floatwz - | "Pfloatuwrnsz" -> Floatuwz - | "Pfloatdrnsz" -> Floatdz - | "Pfloatudrnsz" -> Floatudz - | "Pfixedwrzz" -> Fixedwz - | "Pfixeduwrzz" -> Fixeduwz - | "Pfixeddrzz" -> Fixeddz - | "Pfixedudrzz" -> Fixedudz - | "Pfixeddrzz_i32" -> Fixeddz - | "Pfixedudrzz_i32" -> Fixedudz - | "Pcmove" | "Pcmoveu" -> Cmoved - - | "Plb" -> Lbs - | "Plbu" -> Lbz - | "Plh" -> Lhs - | "Plhu" -> Lhz - | "Plw" | "Plw_a" | "Pfls" -> Lws - | "Pld" | "Pfld" | "Pld_a" -> Ld - | "Plq" -> Lq - | "Plo" -> Lo - - | "Psb" -> Sb - | "Psh" -> Sh - | "Psw" | "Psw_a" | "Pfss" -> Sw - | "Psd" | "Psd_a" | "Pfsd" -> Sd - | "Psq" -> Sq - | "Pso" -> So - - | "Pcb" | "Pcbu" -> Cb - | "Pcall" | "Pdiv" | "Pdivu" -> Call - | "Picall" -> Icall - | "Pgoto" | "Pj_l" -> Goto - | "Pigoto" -> Igoto - | "Pget" -> Get - | "Pret" -> Ret - | "Pset" -> Set - - | "Pfabsd" -> Fabsd - | "Pfabsw" -> Fabsw - | "Pfnegw" -> Fnegw - | "Pfnegd" -> Fnegd - | "Pfaddd" -> Faddd - | "Pfaddw" -> Faddw - | "Pfsbfd" -> Fsbfd - | "Pfsbfw" -> Fsbfw - | "Pfmuld" -> Fmuld - | "Pfmulw" -> Fmulw - - | "nop" -> Nop - - | s -> failwith @@ sprintf "ab_inst_to_real: unrecognized instruction: %s" s - exception InvalidEncoding let rec_to_usage r = let encoding = match r.imm with None -> None | Some (I32 i) | Some (I64 i) -> Some (encode_imm @@ Z.to_int64 i) | Some (Off ptr) -> Some (encode_imm @@ camlint64_of_ptrofs ptr) - and real_inst = ab_inst_to_real r.inst - in match real_inst with + in match r.inst with | Addw | Andw | Nandw | Orw | Norw | Sbfw | Xorw - | Nxorw | Andnw | Ornw -> + | Nxorw | Andnw | Ornw -> (match encoding with None | Some U6 | Some S10 -> alu_tiny | Some U27L5 | Some U27L10 -> alu_tiny_x | _ -> raise InvalidEncoding) + | Sbfxw | Sbfxd -> + (match encoding with None -> alu_lite + | Some U6 | Some S10 | Some U27L5 -> alu_lite_x + | _ -> raise InvalidEncoding) | Addd | Andd | Nandd | Ord | Nord | Sbfd | Xord - | Nxord | Andnd | Ornd | Cmoved -> + | Nxord | Andnd | Ornd -> (match encoding with None | Some U6 | Some S10 -> alu_tiny | Some U27L5 | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> alu_tiny_y) + |Cmoved -> + (match encoding with None | Some U6 | Some S10 -> alu_lite + | Some U27L5 | Some U27L10 -> alu_lite_x + | Some E27U27L10 -> alu_lite_y) + | Addxw -> + (match encoding with None | Some U6 | Some S10 -> alu_lite + | Some U27L5 | Some U27L10 -> alu_lite_x + | _ -> raise InvalidEncoding) + | Addxd -> + (match encoding with None | Some U6 | Some S10 -> alu_lite + | Some U27L5 | Some U27L10 -> alu_lite_x + | Some E27U27L10 -> alu_lite_y) | Compw -> (match encoding with None -> alu_tiny | Some U6 | Some S10 | Some U27L5 -> alu_tiny_x | _ -> raise InvalidEncoding) @@ -596,10 +613,16 @@ let rec_to_usage r = | Some U27L5 | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> alu_tiny_y | _ -> raise InvalidEncoding) - | Mulw| Maddw -> (match encoding with None -> mau + | Maddw -> (match encoding with None -> mau_auxr + | Some U6 | Some S10 | Some U27L5 -> mau_auxr_x + | _ -> raise InvalidEncoding) + | Maddd -> (match encoding with None | Some U6 | Some S10 -> mau_auxr + | Some U27L5 | Some U27L10 -> mau_auxr_x + | Some E27U27L10 -> mau_auxr_y) + | Mulw| Msbfw -> (match encoding with None -> mau | Some U6 | Some S10 | Some U27L5 -> mau_x | _ -> raise InvalidEncoding) - | Muld | Maddd -> (match encoding with None | Some U6 | Some S10 -> mau + | Muld | Msbfd -> (match encoding with None | Some U6 | Some S10 -> mau | Some U27L5 | Some U27L10 -> mau_x | Some E27U27L10 -> mau_y) | Nop -> alu_nop @@ -609,42 +632,64 @@ let rec_to_usage r = | Extfz | Extfs | Insf -> (match encoding with None -> alu_lite | _ -> raise InvalidEncoding) | Fixeduwz | Fixedwz | Floatwz | Floatuwz | Fixeddz | Fixedudz | Floatdz | Floatudz -> mau | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq | Lo -> - (match encoding with None | Some U6 | Some S10 -> lsu_data - | Some U27L5 | Some U27L10 -> lsu_data_x - | Some E27U27L10 -> lsu_data_y) + (match encoding with None | Some U6 | Some S10 -> lsu_auxw + | Some U27L5 | Some U27L10 -> lsu_auxw_x + | Some E27U27L10 -> lsu_auxw_y) | Sb | Sh | Sw | Sd | Sq | So -> - (match encoding with None | Some U6 | Some S10 -> lsu_acc - | Some U27L5 | Some U27L10 -> lsu_acc_x - | Some E27U27L10 -> lsu_acc_y) + (match encoding with None | Some U6 | Some S10 -> lsu_auxr + | Some U27L5 | Some U27L10 -> lsu_auxr_x + | Some E27U27L10 -> lsu_auxr_y) | Icall | Call | Cb | Igoto | Goto | Ret | Set -> bcu | Get -> bcu_tiny_tiny_mau_xnop - | Fnegd | Fnegw | Fabsd | Fabsw | Fwidenlwd -> alu_lite + | Fnegd | Fnegw | Fabsd | Fabsw | Fwidenlwd + | Fmind | Fmaxd | Fminw | Fmaxw -> alu_lite | Fnarrowdw -> alu_full - | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw -> mau + | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw | Finvw + | Ffmad | Ffmaw | Ffmsd | Ffmsw -> mau + + +let inst_info_to_dlatency i = + begin + assert (not (i.reads_at_id && i.reads_at_e1)); + match i.reads_at_id with + | true -> +1 + | false -> (match i.reads_at_e1 with + | true -> -1 + | false -> 0) + end let real_inst_to_latency = function | Nop -> 0 (* Only goes through ID *) - | Addw | Andw | Compw | Orw | Sbfw | Sraw | Srsw | Srlw | Sllw | Xorw + | Addw | Andw | Compw | Orw | Sbfw | Sbfxw | Sraw | Srsw | Srlw | Sllw | Xorw (* TODO check rorw *) | Rorw | Nandw | Norw | Nxorw | Ornw | Andnw | Nandd | Nord | Nxord | Ornd | Andnd - | Addd | Andd | Compd | Ord | Sbfd | Srad | Srsd | Srld | Slld | Xord | Make - | Extfs | Extfz | Insf | Fcompw | Fcompd | Cmoved + | Addd | Andd | Compd | Ord | Sbfd | Sbfxd | Srad | Srsd | Srld | Slld | Xord | Make + | Extfs | Extfz | Insf | Fcompw | Fcompd | Cmoved | Addxw | Addxd + | Fmind | Fmaxd | Fminw | Fmaxw -> 1 | Floatwz | Floatuwz | Fixeduwz | Fixedwz | Floatdz | Floatudz | Fixeddz | Fixedudz -> 4 - | Mulw | Muld | Maddw | Maddd -> 2 (* FIXME - WORST CASE. If it's S10 then it's only 1 *) + | Mulw | Muld | Maddw | Maddd | Msbfw | Msbfd -> 2 (* FIXME - WORST CASE. If it's S10 then it's only 1 *) | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq | Lo -> 3 | Sb | Sh | Sw | Sd | Sq | So -> 1 (* See k1c-Optimization.pdf page 19 *) | Get -> 1 | Set -> 4 (* According to the manual should be 3, but I measured 4 *) | Icall | Call | Cb | Igoto | Goto | Ret -> 42 (* Should not matter since it's the final instruction of the basic block *) | Fnegd | Fnegw | Fabsd | Fabsw | Fwidenlwd | Fnarrowdw -> 1 - | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw -> 4 + | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw | Finvw + | Ffmaw | Ffmad | Ffmsw | Ffmsd -> 4 + +let rec empty_inter la = function + | [] -> true + | b::lb -> if (List.mem b la) then false else empty_inter la lb let rec_to_info r : inst_info = let usage = rec_to_usage r - and latency = real_inst_to_latency @@ ab_inst_to_real r.inst - in { write_locs = r.write_locs; read_locs = r.read_locs; usage=usage; latency=latency; is_control=r.is_control } + and latency = real_inst_to_latency r.inst + and reads_at_id = not (empty_inter r.read_locs r.read_at_id) + and reads_at_e1 = not (empty_inter r.read_locs r.read_at_e1) + in { write_locs = r.write_locs; read_locs = r.read_locs; usage=usage; latency=latency; is_control=r.is_control; + reads_at_id = reads_at_id; reads_at_e1 = reads_at_e1 } let instruction_infos bb = List.map rec_to_info (instruction_recs bb) @@ -656,38 +701,70 @@ let instruction_usages bb = * Latency constraints building *) -type access = { inst: int; loc: location } +(* type access = { inst: int; loc: location } *) -let rec get_accesses llocs laccs = - let accesses loc laccs = List.filter (fun acc -> acc.loc = loc) laccs - in match llocs with - | [] -> [] - | loc :: llocs -> (accesses loc laccs) @ (get_accesses llocs laccs) +let preg2int pr = Camlcoq.P.to_int @@ Asmblockdeps.ppos pr + +let loc2int = function + | Mem -> 1 + | Reg pr -> preg2int pr + +(* module HashedLoc = struct + type t = { loc: location; key: int } + let equal l1 l2 = (l1.key = l2.key) + let hash l = l.key + let create (l:location) : t = { loc=l; key = loc2int l } +end *) + +(* module LocHash = Hashtbl.Make(HashedLoc) *) +module LocHash = Hashtbl + +(* Hash table : location => list of instruction ids *) let rec intlist n = if n < 0 then failwith "intlist: n < 0" else if n = 0 then [] else (n-1) :: (intlist (n-1)) -let latency_constraints bb = (* failwith "latency_constraints: not implemented" *) - let written = ref [] - and read = ref [] +let find_in_hash hashloc loc = + match LocHash.find_opt hashloc loc with + | Some idl -> idl + | None -> [] + +(* Returns a list of instruction ids *) +let rec get_accesses hashloc (ll: location list) = match ll with + | [] -> [] + | loc :: llocs -> (find_in_hash hashloc loc) @ (get_accesses hashloc llocs) + +let compute_latency (ifrom: inst_info) (ito: inst_info) = + let dlat = inst_info_to_dlatency ito + in let lat = ifrom.latency + dlat + in assert (lat >= 0); if (lat == 0) then 1 else lat + +let latency_constraints bb = + let written = LocHash.create 70 + and read = LocHash.create 70 and count = ref 0 and constraints = ref [] and instr_infos = instruction_infos bb - in let step (i: inst_info) = - let write_accesses = List.map (fun loc -> { inst= !count; loc=loc }) i.write_locs - and read_accesses = List.map (fun loc -> { inst= !count; loc=loc }) i.read_locs - in let raw = get_accesses i.read_locs !written - and waw = get_accesses i.write_locs !written - and war = get_accesses i.write_locs !read + in let step (i: inst_info) = + let raw = get_accesses written i.read_locs + and waw = get_accesses written i.write_locs + and war = get_accesses read i.write_locs in begin - List.iter (fun (acc: access) -> constraints := {instr_from = acc.inst; instr_to = !count; latency = (List.nth instr_infos acc.inst).latency} :: !constraints) (raw @ waw); - List.iter (fun (acc: access) -> constraints := {instr_from = acc.inst; instr_to = !count; latency = 0} :: !constraints) war; - (* If it's a control instruction, add an extra 0-lat dependency between this instruction and all the previous ones *) + List.iter (fun i -> constraints := {instr_from = i; instr_to = !count; + latency = compute_latency (List.nth instr_infos i) (List.nth instr_infos !count)} :: !constraints) raw; + List.iter (fun i -> constraints := {instr_from = i; instr_to = !count; + latency = compute_latency (List.nth instr_infos i) (List.nth instr_infos !count)} :: !constraints) waw; + List.iter (fun i -> constraints := {instr_from = i; instr_to = !count; latency = 0} :: !constraints) war; if i.is_control then List.iter (fun n -> constraints := {instr_from = n; instr_to = !count; latency = 0} :: !constraints) (intlist !count); - written := write_accesses @ !written; - read := read_accesses @ !read; + (* Updating "read" and "written" hashmaps *) + List.iter (fun loc -> + begin + LocHash.replace written loc [!count]; + LocHash.replace read loc []; (* Clearing all the entries of "read" hashmap when a register is written *) + end) i.write_locs; + List.iter (fun loc -> LocHash.replace read loc ((!count) :: (find_in_hash read loc))) i.read_locs; count := !count + 1 end in (List.iter step instr_infos; !constraints) @@ -760,15 +837,52 @@ let find_all_indices m l = else find m (off+1) l in find m 0 l +module TimeHash = Hashtbl + +(* Hash table : time => list of instruction ids *) + +let hashtbl2list h maxint = + let rec f i = match TimeHash.find_opt h i with + | None -> if (i > maxint) then [] else (f (i+1)) + | Some bund -> bund :: (f (i+1)) + in f 0 + +let find_max l = + let rec f = function + | [] -> None + | e :: l -> match f l with + | None -> Some e + | Some m -> if (e > m) then Some e else Some m + in match (f l) with + | None -> raise Not_found + | Some m -> m + (* [0, 2, 3, 1, 1, 2, 4, 5] -> [[0], [3, 4], [1, 5], [2], [6], [7]] *) -let minpack_list l = +let minpack_list (l: int list) = + let timehash = TimeHash.create (List.length l) + in let rec f i = function + | [] -> () + | t::l -> begin + (match TimeHash.find_opt timehash t with + | None -> TimeHash.add timehash t [i] + | Some bund -> TimeHash.replace timehash t (bund @ [i])); + f (i+1) l + end + in begin + f 0 l; + hashtbl2list timehash (find_max l) + end;; + +(* let minpack_list l = let mins = find_mins l in List.map (fun m -> find_all_indices m l) mins + *) let bb_to_instrs bb = (List.map apply_pbasic bb.body) @ (match bb.exit with None -> [] | Some e -> [PControl e]) let bundlize_solution bb sol = - let packs = minpack_list (Array.to_list @@ Array.sub sol 0 (Array.length sol - 1)) + let tmp = (Array.to_list @@ Array.sub sol 0 (Array.length sol - 1)) + in let packs = minpack_list tmp and instrs = bb_to_instrs bb in let rec bund hd = function | [] -> [] @@ -792,6 +906,8 @@ let do_schedule bb = validated_scheduler cascaded_scheduler else if !Clflags.option_fpostpass_sched = "list" then validated_scheduler list_scheduler + else if !Clflags.option_fpostpass_sched = "revlist" then + validated_scheduler reverse_list_scheduler else if !Clflags.option_fpostpass_sched = "greedy" then greedy_scheduler else failwith ("Invalid scheduler:" ^ !Clflags.option_fpostpass_sched)) problem in match solution with @@ -881,17 +997,19 @@ let smart_schedule bb = in bundles @ (f lbb) in f lbb -(** Called schedule function from Coq *) - -let schedule bb = +let bblock_to_bundles bb = if debug then (eprintf "###############################\n"; Printf.eprintf "SCHEDULING\n"; print_bb stderr bb); (* print_problem (build_problem bb); *) if Compopts.optim_postpass () then smart_schedule bb else dumb_schedule bb -(** FIXME - Fix for PostpassScheduling WIP *) +(** To deal with the Coq Axiom schedule : bblock -> (list (list basic)) * option control *) -type bblock' = int +let rec bundles_to_coq_schedule = function + | [] -> ([], None) + | bb :: [] -> ([bb.body], bb.exit) + | bb :: lbb -> let (llb, oc) = bundles_to_coq_schedule lbb in (bb.body :: llb, oc) -let trans_block bb = 1 +(** Called schedule function from Coq *) -let bblock_equivb' bb1 bb2 = true +let schedule_notime bb = let toto = bundles_to_coq_schedule @@ bblock_to_bundles bb in toto +let schedule bb = Timing.time_coq ('P'::('o'::('s'::('t'::('p'::('a'::('s'::('s'::('S'::('c'::('h'::('e'::('d'::('u'::('l'::('i'::('n'::('g'::(' '::('o'::('r'::('a'::('c'::('l'::('e'::([])))))))))))))))))))))))))) schedule_notime bb diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 5d4fc881..8cc7f0ab 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -14,7 +14,7 @@ Require Import Coqlib Errors. Require Import Integers Floats AST Linking. Require Import Values Memory Events Globalenvs Smallstep. Require Import Op Locations Machblock Conventions Asmblock. -Require Import Asmblockgenproof0. +Require Import Asmblockgenproof0 Asmblockprops. Require Import PostpassScheduling. Require Import Asmblockgenproof. Require Import Axioms. @@ -30,62 +30,6 @@ Proof. intros. eapply match_transform_partial_program; eauto. Qed. -Remark builtin_body_nil: - forall bb ef args res, exit bb = Some (PExpand (Pbuiltin ef args res)) -> body bb = nil. -Proof. - intros. destruct bb as [hd bdy ex WF]. simpl in *. - apply wf_bblock_refl in WF. inv WF. unfold builtin_alone in H1. - eapply H1; eauto. -Qed. - -Lemma exec_body_app: - forall l l' ge rs m rs'' m'', - exec_body ge (l ++ l') rs m = Next rs'' m'' -> - exists rs' m', - exec_body ge l rs m = Next rs' m' - /\ exec_body ge l' rs' m' = Next rs'' m''. -Proof. - induction l. - - intros. simpl in H. repeat eexists. auto. - - intros. rewrite <- app_comm_cons in H. simpl in H. - destruct (exec_basic_instr ge a rs m) eqn:EXEBI. - + apply IHl in H. destruct H as (rs1 & m1 & EXEB1 & EXEB2). - repeat eexists. simpl. rewrite EXEBI. eauto. auto. - + discriminate. -Qed. - -Lemma exec_body_pc: - forall l ge rs1 m1 rs2 m2, - exec_body ge l rs1 m1 = Next rs2 m2 -> - rs2 PC = rs1 PC. -Proof. - induction l. - - intros. inv H. auto. - - intros until m2. intro EXEB. - inv EXEB. destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate. - eapply IHl in H0. rewrite H0. - erewrite exec_basic_instr_pc; eauto. -Qed. - -Lemma next_eq: - forall (rs rs': regset) m m', - rs = rs' -> m = m' -> Next rs m = Next rs' m'. -Proof. - intros; apply f_equal2; auto. -Qed. - -Lemma regset_double_set: - forall r1 r2 (rs: regset) v1 v2, - r1 <> r2 -> - (rs # r1 <- v1 # r2 <- v2) = (rs # r2 <- v2 # r1 <- v1). -Proof. - intros. apply functional_extensionality. intros r. destruct (preg_eq r r1). - - subst. rewrite Pregmap.gso; auto. repeat (rewrite Pregmap.gss). auto. - - destruct (preg_eq r r2). - + subst. rewrite Pregmap.gss. rewrite Pregmap.gso; auto. rewrite Pregmap.gss. auto. - + repeat (rewrite Pregmap.gso; auto). -Qed. - Lemma regset_double_set_id: forall r (rs: regset) v1 v2, (rs # r <- v1 # r <- v2) = (rs # r <- v2). @@ -95,191 +39,6 @@ Proof. - repeat (rewrite Pregmap.gso); auto. Qed. -Lemma exec_load_offset_pc_var: - forall t rs m rd ra ofs rs' m' v, - exec_load_offset t rs m rd ra ofs = Next rs' m' -> - exec_load_offset t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_load_offset in *. unfold parexec_load_offset in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ofs); try discriminate. - destruct (Mem.loadv _ _ _). - - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. - - discriminate. -Qed. - -Lemma exec_load_reg_pc_var: - forall t rs m rd ra ro rs' m' v, - exec_load_reg t rs m rd ra ro = Next rs' m' -> - exec_load_reg t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_load_reg in *. unfold parexec_load_reg in *. rewrite Pregmap.gso; try discriminate. - destruct (Mem.loadv _ _ _). - - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. - - discriminate. -Qed. - -Lemma exec_load_regxs_pc_var: - forall t rs m rd ra ro rs' m' v, - exec_load_regxs t rs m rd ra ro = Next rs' m' -> - exec_load_regxs t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_load_regxs in *. unfold parexec_load_regxs in *. rewrite Pregmap.gso; try discriminate. - destruct (Mem.loadv _ _ _). - - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. - - discriminate. -Qed. - -Lemma exec_load_offset_q_pc_var: - forall rs m rd ra ofs rs' m' v, - exec_load_q_offset rs m rd ra ofs = Next rs' m' -> - exec_load_q_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_load_q_offset in *. unfold parexec_load_q_offset in *. - destruct (gpreg_q_expand rd) as [rd0 rd1]. - (* destruct (ireg_eq rd0 ra); try discriminate. *) - rewrite Pregmap.gso; try discriminate. - destruct (Mem.loadv _ _ _); try discriminate. - inv H. - destruct (Mem.loadv _ _ _); try discriminate. - inv H1. f_equal. - rewrite (regset_double_set PC rd0) by discriminate. - rewrite (regset_double_set PC rd1) by discriminate. - reflexivity. -Qed. - -Lemma exec_load_offset_o_pc_var: - forall rs m rd ra ofs rs' m' v, - exec_load_o_offset rs m rd ra ofs = Next rs' m' -> - exec_load_o_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_load_o_offset in *. unfold parexec_load_o_offset in *. - destruct (gpreg_o_expand rd) as [[[rd0 rd1] rd2] rd3]. -(* - destruct (ireg_eq rd0 ra); try discriminate. - destruct (ireg_eq rd1 ra); try discriminate. - destruct (ireg_eq rd2 ra); try discriminate. -*) - rewrite Pregmap.gso; try discriminate. - simpl in *. - destruct (Mem.loadv _ _ _); try discriminate. - destruct (Mem.loadv _ _ _); try discriminate. - destruct (Mem.loadv _ _ _); try discriminate. - destruct (Mem.loadv _ _ _); try discriminate. - rewrite (regset_double_set PC rd0) by discriminate. - rewrite (regset_double_set PC rd1) by discriminate. - rewrite (regset_double_set PC rd2) by discriminate. - rewrite (regset_double_set PC rd3) by discriminate. - inv H. - trivial. -Qed. - -Lemma exec_store_offset_pc_var: - forall t rs m rd ra ofs rs' m' v, - exec_store_offset t rs m rd ra ofs = Next rs' m' -> - exec_store_offset t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_store_offset in *. unfold parexec_store_offset in *. rewrite Pregmap.gso; try discriminate. - destruct (eval_offset ofs); try discriminate. - destruct (Mem.storev _ _ _). - - inv H. apply next_eq; auto. - - discriminate. -Qed. - -Lemma exec_store_q_offset_pc_var: - forall rs m rd ra ofs rs' m' v, - exec_store_q_offset rs m rd ra ofs = Next rs' m' -> - exec_store_q_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_store_q_offset in *. unfold parexec_store_q_offset in *. rewrite Pregmap.gso; try discriminate. - simpl in *. - destruct (gpreg_q_expand _) as [s0 s1]. - destruct (Mem.storev _ _ _); try discriminate. - destruct (Mem.storev _ _ _); try discriminate. - inv H. apply next_eq; auto. -Qed. - -Lemma exec_store_o_offset_pc_var: - forall rs m rd ra ofs rs' m' v, - exec_store_o_offset rs m rd ra ofs = Next rs' m' -> - exec_store_o_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. -Proof. - intros. - unfold exec_store_o_offset in *. unfold parexec_store_o_offset in *. - destruct (gpreg_o_expand _) as [[[s0 s1] s2] s3]. - destruct (Mem.storev _ _ _); try discriminate. - destruct (Mem.storev _ _ _); try discriminate. - destruct (Mem.storev _ _ _); try discriminate. - destruct (Mem.storev _ _ _); try discriminate. - inv H. - trivial. -Qed. - -Lemma exec_store_reg_pc_var: - forall t rs m rd ra ro rs' m' v, - exec_store_reg t rs m rd ra ro = Next rs' m' -> - exec_store_reg t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_store_reg in *. unfold parexec_store_reg in *. rewrite Pregmap.gso; try discriminate. - destruct (Mem.storev _ _ _). - - inv H. apply next_eq; auto. - - discriminate. -Qed. - -Lemma exec_store_regxs_pc_var: - forall t rs m rd ra ro rs' m' v, - exec_store_regxs t rs m rd ra ro = Next rs' m' -> - exec_store_regxs t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_store_regxs in *. unfold parexec_store_regxs in *. rewrite Pregmap.gso; try discriminate. - destruct (Mem.storev _ _ _). - - inv H. apply next_eq; auto. - - discriminate. -Qed. - -Lemma exec_basic_instr_pc_var: - forall ge i rs m rs' m' v, - exec_basic_instr ge i rs m = Next rs' m' -> - exec_basic_instr ge i (rs # PC <- v) m = Next (rs' # PC <- v) m'. -Proof. - intros. unfold exec_basic_instr in *. unfold parexec_basic_instr in *. destruct i. - - unfold exec_arith_instr in *. destruct i; destruct i. - all: try (exploreInst; inv H; apply next_eq; auto; - apply functional_extensionality; intros; rewrite regset_double_set; auto; discriminate). -(* - (* Some cases treated seperately because exploreInst destructs too much *) - all: try (inv H; apply next_eq; auto; apply functional_extensionality; intros; rewrite regset_double_set; auto; discriminate). *) - - destruct i. - + exploreInst; apply exec_load_offset_pc_var; auto. - + exploreInst; apply exec_load_reg_pc_var; auto. - + exploreInst; apply exec_load_regxs_pc_var; auto. - + apply exec_load_offset_q_pc_var; auto. - + apply exec_load_offset_o_pc_var; auto. - - destruct i. - + exploreInst; apply exec_store_offset_pc_var; auto. - + exploreInst; apply exec_store_reg_pc_var; auto. - + exploreInst; apply exec_store_regxs_pc_var; auto. - + apply exec_store_q_offset_pc_var; auto. - + apply exec_store_o_offset_pc_var; auto. - - destruct (Mem.alloc _ _ _) as (m1 & stk). repeat (rewrite Pregmap.gso; try discriminate). - destruct (Mem.storev _ _ _ _); try discriminate. - inv H. apply next_eq; auto. apply functional_extensionality. intros. - rewrite (regset_double_set GPR32 PC); try discriminate. - rewrite (regset_double_set GPR12 PC); try discriminate. - rewrite (regset_double_set FP PC); try discriminate. reflexivity. - - repeat (rewrite Pregmap.gso; try discriminate). - destruct (Mem.loadv _ _ _); try discriminate. - destruct (rs GPR12); try discriminate. - destruct (Mem.free _ _ _ _); try discriminate. - inv H. apply next_eq; auto. - rewrite (regset_double_set GPR32 PC). - rewrite (regset_double_set GPR12 PC). reflexivity. - all: discriminate. - - destruct rs0; try discriminate. inv H. apply next_eq; auto. - repeat (rewrite Pregmap.gso; try discriminate). apply regset_double_set; discriminate. - - destruct rd; try discriminate. inv H. apply next_eq; auto. - repeat (rewrite Pregmap.gso; try discriminate). apply regset_double_set; discriminate. - - inv H. apply next_eq; auto. -Qed. - Lemma exec_body_pc_var: forall l ge rs m rs' m' v, exec_body ge l rs m = Next rs' m' -> @@ -302,9 +61,9 @@ Proof. - subst. repeat (rewrite Pregmap.gss); auto. destruct v; simpl; auto. rewrite Ptrofs.add_assoc. - cutrewrite (Ptrofs.repr (x + y) = Ptrofs.add (Ptrofs.repr x) (Ptrofs.repr y)); auto. + enough (Ptrofs.repr (x + y) = Ptrofs.add (Ptrofs.repr x) (Ptrofs.repr y)) as ->; auto. unfold Ptrofs.add. - cutrewrite (x + y = Ptrofs.unsigned (Ptrofs.repr x) + Ptrofs.unsigned (Ptrofs.repr y)); auto. + enough (x + y = Ptrofs.unsigned (Ptrofs.repr x) + Ptrofs.unsigned (Ptrofs.repr y)) as ->; auto. repeat (rewrite Ptrofs.unsigned_repr); auto. - repeat (rewrite Pregmap.gso; auto). Qed. @@ -461,7 +220,8 @@ Proof. destruct (zeq pos 0). + inv H. exists lbb. constructor; auto. + apply IHlbb in H. destruct H as (c & TAIL). exists c. - cutrewrite (pos = pos - size a + size a). apply code_tail_S; auto. + enough (pos = pos - size a + size a) as ->. + apply code_tail_S; auto. omega. Qed. @@ -681,7 +441,7 @@ Lemma transf_exec_basic_instr: forall i rs m, exec_basic_instr ge i rs m = exec_basic_instr tge i rs m. Proof. intros. pose symbol_address_preserved. - unfold exec_basic_instr. unfold parexec_basic_instr. exploreInst; simpl; auto; try congruence. + unfold exec_basic_instr. unfold bstep. exploreInst; simpl; auto; try congruence. unfold parexec_arith_instr; unfold arith_eval_r; exploreInst; simpl; auto; try congruence. Qed. @@ -736,7 +496,7 @@ Proof. induction 1; intros; inv MS. - exploit function_ptr_translated; eauto. intros (tf & FFP & TRANSF). monadInv TRANSF. exploit transf_find_bblock; eauto. intros (lbb & VES & c & TAIL). - exploit verified_schedule_correct; eauto. intros (tbb & CONC & BBEQ). + exploit verified_schedule_correct; eauto. intros (tbb & CONC & BBEQ). inv CONC. rename H3 into CONC. assert (NOOV: size_blocks x.(fn_blocks) <= Ptrofs.max_unsigned). eapply transf_function_no_overflow; eauto. @@ -776,12 +536,8 @@ Qed. End PRESERVATION_ASMBLOCK. - - - Require Import Asmvliw. - Lemma verified_par_checks_alls_bundles lb x: forall bundle, verify_par lb = OK x -> List.In bundle lb -> verify_par_bblock bundle = OK tt. @@ -792,13 +548,12 @@ Proof. destruct x0; auto. Qed. - Lemma verified_schedule_nob_checks_alls_bundles bb lb bundle: verified_schedule_nob bb = OK lb -> List.In bundle lb -> verify_par_bblock bundle = OK tt. Proof. unfold verified_schedule_nob. intros H; - monadInv H. destruct x3. + monadInv H. destruct x4. intros; eapply verified_par_checks_alls_bundles; eauto. Qed. @@ -813,7 +568,7 @@ Proof. unfold builtin_alone in H0. erewrite H0; eauto. Qed. -Local Hint Resolve verified_schedule_nob_checks_alls_bundles. +Local Hint Resolve verified_schedule_nob_checks_alls_bundles: core. Lemma verified_schedule_checks_alls_bundles bb lb bundle: verified_schedule bb = OK lb -> @@ -914,9 +669,6 @@ Qed. End PRESERVATION_ASMVLIW. - - - Section PRESERVATION. Variables prog tprog: program. diff --git a/mppa_k1c/PrintOp.ml b/mppa_k1c/PrintOp.ml index 4b833014..67f87000 100644 --- a/mppa_k1c/PrintOp.ml +++ b/mppa_k1c/PrintOp.ml @@ -21,7 +21,8 @@ open Printf open Camlcoq open Integers open Op - +open ExtValues + let comparison_name = function | Ceq -> "==" | Cne -> "!=" @@ -58,7 +59,20 @@ let print_condition reg pp = function | _ -> fprintf pp "<bad condition>" -let print_operation reg pp = function +let print_condition0 reg pp cond0 rc = + match cond0 with + | Ccomp0 c -> fprintf pp "%a %ss 0" reg rc (comparison_name c) + | Ccompu0 c -> fprintf pp "%a %su 0" reg rc (comparison_name c) + | Ccompl0 c -> fprintf pp "%a %ss 0" reg rc (comparison_name c) + | Ccomplu0 c -> fprintf pp "%a %su 0" reg rc (comparison_name c) + +let int_of_s14 = function + | SHIFT1 -> 1 + | SHIFT2 -> 2 + | SHIFT3 -> 3 + | SHIFT4 -> 4 + +let print_operation reg pp op = match op with | Omove, [r1] -> reg pp r1 | Ointconst n, [] -> fprintf pp "%ld" (camlint_of_coqint n) | Olongconst n, [] -> fprintf pp "%LdL" (camlint64_of_coqint n) @@ -72,9 +86,15 @@ let print_operation reg pp = function | Ocast16signed, [r1] -> fprintf pp "int16signed(%a)" reg r1 | Oadd, [r1;r2] -> fprintf pp "%a + %a" reg r1 reg r2 | Oaddimm n, [r1] -> fprintf pp "%a + %ld" reg r1 (camlint_of_coqint n) + | Oaddx(s14), [r1; r2] -> fprintf pp "(%a << %d) + %a" reg r1 (int_of_s14 s14) reg r2 + | Oaddximm(s14, imm), [r1] -> fprintf pp "(%a << %d) + %ld" reg r1 (int_of_s14 s14) (camlint_of_coqint imm) | Oneg, [r1] -> fprintf pp "-(%a)" reg r1 | Osub, [r1;r2] -> fprintf pp "%a - %a" reg r1 reg r2 + | Orevsubimm(imm), [r1] -> fprintf pp "%ld - %a" (camlint_of_coqint imm) reg r1 + | Orevsubx(s14), [r1; r2] -> fprintf pp "%a - (%a << %d)" reg r2 reg r1 (int_of_s14 s14) + | Orevsubximm(s14, imm), [r1] -> fprintf pp "%ld - (%a << %d)" (camlint_of_coqint imm) reg r1 (int_of_s14 s14) | Omul, [r1;r2] -> fprintf pp "%a * %a" reg r1 reg r2 + | Omulimm(imm), [r1] -> fprintf pp "%a * %ld" reg r1 (camlint_of_coqint imm) | Omulhs, [r1;r2] -> fprintf pp "%a *hs %a" reg r1 reg r2 | Omulhu, [r1;r2] -> fprintf pp "%a *hu %a" reg r1 reg r2 | Odiv, [r1;r2] -> fprintf pp "%a /s %a" reg r1 reg r2 @@ -87,6 +107,13 @@ 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) + | Onxor, [r1;r2] -> fprintf pp "~(%a ^ %a)" reg r1 reg r2 + | Onxorimm n, [r1] -> fprintf pp "~(%a ^ %ld)" reg r1 (camlint_of_coqint n) + | Onot, [r1] -> fprintf pp "~%a" reg r1 + | Oandn, [r1; r2] -> fprintf pp "(~%a) & %a" reg r1 reg r2 + | Oandnimm n, [r1] -> fprintf pp "(~%a) & %ld" reg r1 (camlint_of_coqint n) + | Oorn, [r1;r2] -> fprintf pp "(~%a) | %a" reg r1 reg r2 + | Oornimm n, [r1] -> fprintf pp "(~%a) | %ld" reg r1 (camlint_of_coqint n) | 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 @@ -94,6 +121,10 @@ let print_operation reg pp = function | Oshru, [r1;r2] -> fprintf pp "%a >>u %a" reg r1 reg r2 | Oshruimm n, [r1] -> fprintf pp "%a >>u %ld" reg r1 (camlint_of_coqint n) | Oshrximm n, [r1] -> fprintf pp "%a >>x %ld" reg r1 (camlint_of_coqint n) + | Ororimm n, [r1] -> fprintf pp "(%a ror %ld)" reg r1 (camlint_of_coqint n) + | Omadd, [r1; r2; r3] -> fprintf pp "%a + %a * %a" reg r1 reg r2 reg r3 + | Omaddimm imm, [r1; r2] -> fprintf pp "%a + %a * %ld" reg r1 reg r2 (camlint_of_coqint imm) + | Omsub, [r1; r2; r3] -> fprintf pp "%a - %a * %a" reg r1 reg r2 reg r3 | Omakelong, [r1;r2] -> fprintf pp "makelong(%a,%a)" reg r1 reg r2 | Olowlong, [r1] -> fprintf pp "lowlong(%a)" reg r1 @@ -102,9 +133,15 @@ let print_operation reg pp = function | Ocast32unsigned, [r1] -> fprintf pp "long32unsigned(%a)" reg r1 | Oaddl, [r1;r2] -> fprintf pp "%a +l %a" reg r1 reg r2 | Oaddlimm n, [r1] -> fprintf pp "%a +l %Ld" reg r1 (camlint64_of_coqint n) + | Oaddxl(s14), [r1; r2] -> fprintf pp "(%a <<l %d) +l %a" reg r1 (int_of_s14 s14) reg r2 + | Oaddxlimm(s14, imm), [r1] -> fprintf pp "(%a <<l %d) +l %Ld" reg r1 (int_of_s14 s14) (camlint64_of_coqint imm) + | Orevsublimm(imm), [r1] -> fprintf pp "%Ld -l %a" (camlint64_of_coqint imm) reg r1 + | Orevsubxl(s14), [r1; r2] -> fprintf pp "%a -l (%a <<l %d)" reg r2 reg r1 (int_of_s14 s14) + | Orevsubxlimm(s14, imm), [r1] -> fprintf pp "%Ld -l (%a <<l %d)" (camlint64_of_coqint imm) reg r1 (int_of_s14 s14) | 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(imm), [r1] -> fprintf pp "%a *l %Ld" reg r1 (camlint64_of_coqint imm) | Omullhs, [r1;r2] -> fprintf pp "%a *lhs %a" reg r1 reg r2 | Omullhu, [r1;r2] -> fprintf pp "%a *lhu %a" reg r1 reg r2 | Odivl, [r1;r2] -> fprintf pp "%a /ls %a" reg r1 reg r2 @@ -115,8 +152,17 @@ let print_operation reg pp = function | 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) + | Onorl, [r1; r2] -> fprintf pp "~(%a |l %a)" reg r1 reg r2 + | Onorlimm 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) + | Onxorl, [r1;r2] -> fprintf pp "~(%a ^l %a)" reg r1 reg r2 + | Onxorlimm n, [r1] -> fprintf pp "~(%a ^l %Ld)" reg r1 (camlint64_of_coqint n) + | Onotl, [r1] -> fprintf pp "~%a" reg r1 + | Oandnl, [r1;r2] -> fprintf pp "(~%a) &l %a" reg r1 reg r2 + | Oandnlimm n, [r1] -> fprintf pp "(~%a) &l %Ld" reg r1 (camlint64_of_coqint n) + | Oornl, [r1;r2] -> fprintf pp "(~%a) |l %a" reg r1 reg r2 + | Oornlimm n, [r1;r2] -> fprintf pp "(~%a) |l %Ld" reg r1 (camlint64_of_coqint n) | Oshll, [r1;r2] -> fprintf pp "%a <<l %a" reg r1 reg r2 | Oshllimm n, [r1] -> fprintf pp "%a <<l %Ld" reg r1 (camlint64_of_coqint n) | Oshrl, [r1;r2] -> fprintf pp "%a >>ls %a" reg r1 reg r2 @@ -124,6 +170,9 @@ let print_operation reg pp = function | 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) | Oshrxlimm n, [r1] -> fprintf pp "%a >>lx %ld" reg r1 (camlint_of_coqint n) + | Omaddl, [r1; r2; r3] -> fprintf pp "%a +l %a *l %a" reg r1 reg r2 reg r3 + | Omaddlimm imm, [r1; r2] -> fprintf pp "%a +l %a *l %Ld" reg r1 reg r2 (camlint64_of_coqint imm) + | Omsubl, [r1; r2; r3] -> fprintf pp "%a -l %a *l %a" reg r1 reg r2 reg r3 | Onegf, [r1] -> fprintf pp "negf(%a)" reg r1 | Oabsf, [r1] -> fprintf pp "absf(%a)" reg r1 @@ -141,24 +190,41 @@ let print_operation reg pp = function | Ofloatofsingle, [r1] -> fprintf pp "floatofsingle(%a)" reg r1 | Ointoffloat, [r1] -> fprintf pp "intoffloat(%a)" reg r1 | Ointuoffloat, [r1] -> fprintf pp "intuoffloat(%a)" reg r1 - | Olongoffloat, [r1] -> fprintf pp "longoffloat(%a)" reg r1 - | Olonguoffloat, [r1] -> fprintf pp "longuoffloat(%a)" reg r1 - | Ofloatoflong, [r1] -> fprintf pp "floatoflong(%a)" reg r1 - | Ofloatoflongu, [r1] -> fprintf pp "floatoflongu(%a)" reg r1 | Ointofsingle, [r1] -> fprintf pp "intofsingle(%a)" reg r1 | Ointuofsingle, [r1] -> fprintf pp "intuofsingle(%a)" reg r1 | Osingleofint, [r1] -> fprintf pp "singleofint(%a)" reg r1 | Osingleofintu, [r1] -> fprintf pp "singleofintu(%a)" reg r1 + | Olongoffloat, [r1] -> fprintf pp "longoffloat(%a)" reg r1 + | Olonguoffloat, [r1] -> fprintf pp "longuoffloat(%a)" reg r1 + | Ofloatoflong, [r1] -> fprintf pp "floatoflong(%a)" reg r1 + | Ofloatoflongu, [r1] -> fprintf pp "floatoflongu(%a)" reg r1 | Olongofsingle, [r1] -> fprintf pp "longofsingle(%a)" reg r1 | Olonguofsingle, [r1] -> fprintf pp "longuofsingle(%a)" reg r1 | Osingleoflong, [r1] -> fprintf pp "singleoflong(%a)" reg r1 | Osingleoflongu, [r1] -> fprintf pp "singleoflongu(%a)" reg r1 | Ocmp c, args -> print_condition reg pp (c, args) - | _ -> fprintf pp "<bad operator>" + + | Oextfz(stop, start), [r1] -> fprintf pp "extfz(%ld, %ld, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 + | Oextfs(stop, start), [r1] -> fprintf pp "extfs(%ld, %ld, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 + | Oextfzl(stop, start), [r1] -> fprintf pp "extfzl(%ld, %ld, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 + | Oextfsl(stop, start), [r1] -> fprintf pp "extfsl(%ld, %ld, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 + | Oinsf(stop, start), [r1; r2] -> fprintf pp "insf(%ld, %ld, %a, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 reg r2 + | Oinsfl(stop, start), [r1; r2] -> fprintf pp "insfl(%ld, %ld, %a, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 reg r2 + | Osel(cond0, ty), [r1; r2; rc] -> + print_condition0 reg pp cond0 rc; + fprintf pp " ? %a : %a" reg r1 reg r2 + | Oselimm(cond0, imm), [r1; rc] -> + print_condition0 reg pp cond0 rc; + fprintf pp " ? %a : %ld" reg r1 (camlint_of_coqint imm) + | Osellimm(cond0, imm), [r1; rc] -> + print_condition0 reg pp cond0 rc; + fprintf pp " ? %a :l %Ld" reg r1 (camlint64_of_coqint imm) + | _, _ -> fprintf pp "<bad operator>" let print_addressing reg pp = function - | Aindexed n, [r1] -> fprintf pp "%a + %Ld" reg r1 (camlint64_of_ptrofs n) + | Aindexed2XS scale, [r1;r2] -> fprintf pp "%a + (%a << %ld)" reg r1 reg r2 (camlint_of_coqint scale) | Aindexed2, [r1;r2] -> fprintf pp "%a + %a" reg r1 reg r2 + | Aindexed n, [r1] -> fprintf pp "%a + %Ld" reg r1 (camlint64_of_ptrofs n) | Aglobal(id, ofs), [] -> fprintf pp "\"%s\" + %Ld" (extern_atom id) (camlint64_of_ptrofs ofs) | Ainstack ofs, [] -> fprintf pp "stack(%Ld)" (camlint64_of_ptrofs ofs) diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index 717b0120..981c796c 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -66,19 +66,39 @@ Definition longofintu (e: expr) := (** ** Integer addition and pointer addition *) +Definition addlimm_shllimm sh k2 e1 := + if Compopts.optim_addx tt + then + match shift1_4_of_z (Int.unsigned sh) with + | Some s14 => Eop (Oaddxlimm s14 k2) (e1:::Enil) + | None => Eop (Oaddlimm k2) ((Eop (Oshllimm sh) (e1:::Enil)):::Enil) + end + else Eop (Oaddlimm k2) ((Eop (Oshllimm sh) (e1:::Enil)):::Enil). + 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 (Oaddrsymbol s m) Enil => - (if Compopts.optim_fglobaladdroffset tt + (if Compopts.optim_globaladdroffset tt then Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int64 n) m)) Enil else Eop (Oaddlimm n) (e ::: Enil)) | Eop (Oaddrstack m) Enil => Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int64 n) m)) Enil | Eop (Oaddlimm m) (t ::: Enil) => Eop (Oaddlimm(Int64.add n m)) (t ::: Enil) + | Eop (Oaddxlimm sh m) (t ::: Enil) => Eop (Oaddxlimm sh (Int64.add n m)) (t ::: Enil) + | Eop (Oshllimm sh) (t1:::Enil) => addlimm_shllimm sh n t1 | _ => Eop (Oaddlimm n) (e ::: Enil) end. +Definition addl_shllimm n e1 e2 := + if Compopts.optim_addx tt + then + match shift1_4_of_z (Int.unsigned n) with + | Some s14 => Eop (Oaddxl s14) (e1:::e2:::Enil) + | None => Eop Oaddl (e2:::(Eop (Oshllimm n) (e1:::Enil)):::Enil) + end + else Eop Oaddl (e2:::(Eop (Oshllimm n) (e1:::Enil)):::Enil). + Nondetfunction addl (e1: expr) (e2: expr) := if Archi.splitlong then SplitLong.addl e1 e2 else match e1, e2 with @@ -102,6 +122,10 @@ Nondetfunction addl (e1: expr) (e2: expr) := Eop (Omaddlimm n) (t1:::t2:::Enil) | (Eop (Omullimm n) (t2:::Enil)), t1 => Eop (Omaddlimm n) (t1:::t2:::Enil) + | (Eop (Oshllimm n) (t1:::Enil)), t2 => + addl_shllimm n t1 t2 + | t2, (Eop (Oshllimm n) (t1:::Enil)) => + addl_shllimm n t1 t2 | _, _ => Eop Oaddl (e1:::e2:::Enil) end. @@ -118,6 +142,10 @@ Nondetfunction subl (e1: expr) (e2: expr) := addlimm n1 (Eop Osubl (t1:::t2:::Enil)) | t1, Eop (Oaddlimm n2) (t2:::Enil) => addlimm (Int64.neg n2) (Eop Osubl (t1:::t2:::Enil)) + | t1, (Eop Omull (t2:::t3:::Enil)) => + Eop Omsubl (t1:::t2:::t3:::Enil) + | t1, (Eop (Omullimm n) (t2:::Enil)) => + Eop (Omaddlimm (Int64.neg n)) (t1:::t2:::Enil) | _, _ => Eop Osubl (e1:::e2:::Enil) end. @@ -225,7 +253,7 @@ Definition mullimm_base (n1: int64) (e2: expr) := | i :: j :: nil => Elet e2 (addl (shllimm (Eletvar 0) i) (shllimm (Eletvar 0) j)) | _ => - Eop Omull (e2 ::: longconst n1 ::: Enil) + Eop (Omullimm n1) (e2 ::: Enil) end. Nondetfunction mullimm (n1: int64) (e2: expr) := @@ -278,14 +306,6 @@ Nondetfunction andl (e1: expr) (e2: expr) := | t1, (Eop Onotl (t2:::Enil)) => Eop Oandnl (t2:::t1:::Enil) | _, _ => Eop Oandl (e1:::e2:::Enil) end. -(* - | (Eop Ocast32signed - ((Eop Oneg ((Eop (Ocmp (Ccomplimm Cne zero1)) - (y1:::Enil)):::Enil)):::Enil)), v1 => - if Int64.eq zero1 Int64.zero - then Eop Oselectl ((Eop (Olongconst Int64.zero) Enil):::v1:::y1:::Enil) - else Eop Oandl (e1:::e2:::Enil) -*) Nondetfunction orlimm (n1: int64) (e2: expr) := if Int64.eq n1 Int64.zero then e2 else @@ -304,17 +324,6 @@ Nondetfunction orl (e1: expr) (e2: expr) := | t1, Eop (Olongconst n2) Enil => orlimm n2 t1 | (Eop Onotl (t1:::Enil)), t2 => Eop Oornl (t1:::t2:::Enil) | t1, (Eop Onotl (t2:::Enil)) => Eop Oornl (t2:::t1:::Enil) - | (Eop Oandl ((Eop Ocast32signed - ((Eop Oneg ((Eop (Ocmp (Ccomplimm Ceq zero0)) - (y0:::Enil)):::Enil)):::Enil)):::v0:::Enil)), - (Eop Oandl ((Eop Ocast32signed - ((Eop Oneg ((Eop (Ocmp (Ccomplimm Cne zero1)) - (y1:::Enil)):::Enil)):::Enil)):::v1:::Enil)) => - if same_expr_pure y0 y1 - && Int64.eq zero0 Int64.zero - && Int64.eq zero1 Int64.zero - then Eop (Oselectl (Ccompl0 Cne)) (v0:::v1:::y0:::Enil) - else Eop Oorl (e1:::e2:::Enil) | (Eop (Oandlimm nmask) (prev:::Enil)), (Eop (Oandlimm mask) ((Eop (Oshllimm start) (fld:::Enil)):::Enil)) => diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 3b724c01..ada02585 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -119,6 +119,76 @@ Proof. - TrivialExists. Qed. + +Theorem eval_addlimm_shllimm: + forall sh k2, unary_constructor_sound (addlimm_shllimm sh k2) (fun x => ExtValues.addxl sh x (Vlong k2)). +Proof. + red; unfold addlimm_shllimm; intros. + destruct (Compopts.optim_addx tt). + { + destruct (shift1_4_of_z (Int.unsigned sh)) as [s14 |] eqn:SHIFT. + - TrivialExists. simpl. + f_equal. + unfold shift1_4_of_z, int_of_shift1_4, z_of_shift1_4 in *. + destruct (Z.eq_dec _ _) as [e1|]. + { replace s14 with SHIFT1 by congruence. + destruct x; simpl; trivial. + replace (Int.ltu _ _) with true by reflexivity. + unfold Int.ltu. + rewrite e1. + replace (if zlt _ _ then true else false) with true by reflexivity. + rewrite <- e1. + rewrite Int.repr_unsigned. + reflexivity. + } + destruct (Z.eq_dec _ _) as [e2|]. + { replace s14 with SHIFT2 by congruence. + destruct x; simpl; trivial. + replace (Int.ltu _ _) with true by reflexivity. + unfold Int.ltu. + rewrite e2. + replace (if zlt _ _ then true else false) with true by reflexivity. + rewrite <- e2. + rewrite Int.repr_unsigned. + reflexivity. + } + destruct (Z.eq_dec _ _) as [e3|]. + { replace s14 with SHIFT3 by congruence. + destruct x; simpl; trivial. + replace (Int.ltu _ _) with true by reflexivity. + unfold Int.ltu. + rewrite e3. + replace (if zlt _ _ then true else false) with true by reflexivity. + rewrite <- e3. + rewrite Int.repr_unsigned. + reflexivity. + } + destruct (Z.eq_dec _ _) as [e4|]. + { replace s14 with SHIFT4 by congruence. + destruct x; simpl; trivial. + replace (Int.ltu _ _) with true by reflexivity. + unfold Int.ltu. + rewrite e4. + replace (if zlt _ _ then true else false) with true by reflexivity. + rewrite <- e4. + rewrite Int.repr_unsigned. + reflexivity. + } + discriminate. + - unfold addxl. rewrite Val.addl_commut. + TrivialExists. + repeat (try eassumption; try econstructor). + simpl. + reflexivity. + } + { unfold addxl. rewrite Val.addl_commut. + TrivialExists. + repeat (try eassumption; try econstructor). + simpl. + reflexivity. + } +Qed. + Theorem eval_addlimm: forall n, unary_constructor_sound (addlimm n) (fun v => Val.addl v (Vlong n)). Proof. unfold addlimm; intros; red; intros. @@ -127,7 +197,7 @@ Proof. destruct x; simpl; rewrite ?Int64.add_zero, ?Ptrofs.add_zero; auto. destruct (addlimm_match a); InvEval. - econstructor; split. apply eval_longconst. rewrite Int64.add_commut; auto. -- destruct (Compopts.optim_fglobaladdroffset _). +- destruct (Compopts.optim_globaladdroffset _). + econstructor; split. EvalOp. simpl; eauto. unfold Genv.symbol_address. destruct (Genv.find_symbol ge s); simpl; auto. destruct Archi.ptr64; auto. rewrite Ptrofs.add_commut; auto. @@ -136,9 +206,58 @@ Proof. destruct sp; simpl; auto. destruct Archi.ptr64; auto. rewrite Ptrofs.add_assoc, (Ptrofs.add_commut m0). auto. - subst x. rewrite Val.addl_assoc. rewrite Int64.add_commut. TrivialExists. +- TrivialExists; simpl. subst x. + destruct v1; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. + rewrite Int64.add_assoc. rewrite Int64.add_commut. + reflexivity. +- pose proof eval_addlimm_shllimm as ADDXL. + unfold unary_constructor_sound in ADDXL. + unfold addxl in ADDXL. + rewrite Val.addl_commut. + subst x. + apply ADDXL; assumption. - TrivialExists. Qed. +Lemma eval_addxl: forall n, binary_constructor_sound (addl_shllimm n) (ExtValues.addxl n). +Proof. + red. + intros. + unfold addl_shllimm. + destruct (Compopts.optim_addx tt). + { + destruct (shift1_4_of_z (Int.unsigned n)) as [s14 |] eqn:SHIFT. + - TrivialExists. + simpl. + f_equal. f_equal. + unfold shift1_4_of_z, int_of_shift1_4, z_of_shift1_4 in *. + destruct (Z.eq_dec _ _) as [e1|]. + { replace s14 with SHIFT1 by congruence. + rewrite <- e1. + apply Int.repr_unsigned. } + destruct (Z.eq_dec _ _) as [e2|]. + { replace s14 with SHIFT2 by congruence. + rewrite <- e2. + apply Int.repr_unsigned. } + destruct (Z.eq_dec _ _) as [e3|]. + { replace s14 with SHIFT3 by congruence. + rewrite <- e3. + apply Int.repr_unsigned. } + destruct (Z.eq_dec _ _) as [e4|]. + { replace s14 with SHIFT4 by congruence. + rewrite <- e4. + apply Int.repr_unsigned. } + discriminate. + (* Oaddxl *) + - TrivialExists; + repeat econstructor; eassumption. + } + { TrivialExists; + repeat econstructor; eassumption. + } +Qed. + Theorem eval_addl: binary_constructor_sound addl Val.addl. Proof. unfold addl. destruct Archi.splitlong eqn:SL. @@ -193,6 +312,14 @@ Proof. - subst. rewrite Val.addl_commut. TrivialExists. - subst. TrivialExists. - subst. rewrite Val.addl_commut. TrivialExists. + - subst. pose proof eval_addxl as ADDXL. + unfold binary_constructor_sound in ADDXL. + rewrite Val.addl_commut. + apply ADDXL; assumption. + (* Oaddxl *) + - subst. pose proof eval_addxl as ADDXL. + unfold binary_constructor_sound in ADDXL. + apply ADDXL; assumption. - TrivialExists. Qed. @@ -208,6 +335,23 @@ Proof. - subst. rewrite Val.subl_addl_l. apply eval_addlimm; EvalOp. - subst. rewrite Val.subl_addl_r. apply eval_addlimm; EvalOp. +- TrivialExists. simpl. subst. reflexivity. +- TrivialExists. simpl. subst. + destruct v1; destruct x; simpl; trivial. + + f_equal. f_equal. + rewrite <- Int64.neg_mul_distr_r. + rewrite Int64.sub_add_opp. + reflexivity. + + destruct (Archi.ptr64) eqn:ARCHI64; simpl; trivial. + f_equal. f_equal. + rewrite <- Int64.neg_mul_distr_r. + rewrite Ptrofs.sub_add_opp. + unfold Ptrofs.add. + f_equal. f_equal. + rewrite (Ptrofs.agree64_neg ARCHI64 (Ptrofs.of_int64 (Int64.mul i n)) (Int64.mul i n)). + rewrite (Ptrofs.agree64_of_int ARCHI64 (Int64.neg (Int64.mul i n))). + reflexivity. + apply (Ptrofs.agree64_of_int ARCHI64). - TrivialExists. Qed. @@ -371,7 +515,7 @@ Proof. auto. } generalize (Int64.one_bits'_decomp n); intros D. destruct (Int64.one_bits' n) as [ | i [ | j [ | ? ? ]]] eqn:B. -- apply DEFAULT. +- TrivialExists. - replace (Val.mull x (Vlong n)) with (Val.shll x (Vint i)). apply eval_shllimm; auto. simpl in D. rewrite D, Int64.add_zero. destruct x; simpl; auto. @@ -389,7 +533,7 @@ Proof. rewrite (Int64.one_bits'_range n) in B2 by (rewrite B; auto with coqlib). inv B1; inv B2. simpl in B3; inv B3. rewrite Int64.mul_add_distr_r. rewrite <- ! Int64.shl'_mul. auto. -- apply DEFAULT. +- TrivialExists. Qed. Theorem eval_mullimm: forall n, unary_constructor_sound (mullimm n) (fun v => Val.mull v (Vlong n)). @@ -516,81 +660,6 @@ Proof. - InvEval. apply eval_orlimm; auto. - (*orn*) InvEval. TrivialExists; simpl; congruence. - (*orn reversed*) InvEval. rewrite Val.orl_commut. TrivialExists; simpl; congruence. - - (* selectl *) - destruct (same_expr_pure y0 y1) eqn:PURE; simpl; try TrivialExists. - predSpec Int64.eq Int64.eq_spec zero0 Int64.zero; simpl; try TrivialExists. - predSpec Int64.eq Int64.eq_spec zero1 Int64.zero; simpl; [ | TrivialExists]. - inv H. - inv H0. - inv H6. - inv H3. - inv H2. - inv H7. - inv H4. - inv H3. - inv H6. - inv H4. - inv H3. - inv H14. - inv H13. - inv H6. - inv H4. - inv H13. - inv H14. - inv H9. - inv H11. - inv H13. - inv H3. - inv H6. - inv H7. - inv H3. - inv H14. - inv H17. - simpl in *. - inv H8. - inv H5. - inv H10. - inv H12. - inv H15. - inv H16. - inv H11. - inv H13. - unfold same_expr_pure in PURE. - destruct y0; try congruence. - destruct y1; try congruence. - destruct (ident_eq i i0); try congruence; clear PURE. - rewrite <- e0 in *; clear e0. - inv H6. - inv H7. - rename v10 into vtest. - replace v11 with vtest in * by congruence. - TrivialExists. - simpl. - f_equal. - rewrite eval_selectl_to2. - unfold eval_selectl2. - destruct vtest; simpl; trivial. - rewrite Val.andl_commut. - destruct v4; simpl; trivial. - rewrite Val.andl_commut. - rewrite Val.orl_commut. - destruct v9; simpl; trivial. - rewrite int64_eq_commut. - destruct (Int64.eq Int64.zero i1); simpl. - - + replace (Int64.repr (Int.signed (Int.neg Int.one))) with Int64.mone by Int64.bit_solve. - replace (Int64.repr (Int.signed (Int.neg Int.zero))) with Int64.zero by Int64.bit_solve. - rewrite Int64.and_mone. - rewrite Int64.and_zero. - rewrite Int64.or_commut. - rewrite Int64.or_zero. - reflexivity. - + replace (Int64.repr (Int.signed (Int.neg Int.one))) with Int64.mone by Int64.bit_solve. - replace (Int64.repr (Int.signed (Int.neg Int.zero))) with Int64.zero by Int64.bit_solve. - rewrite Int64.and_mone. - rewrite Int64.and_zero. - rewrite Int64.or_zero. - reflexivity. - (*insfl first case*) destruct (is_bitfieldl _ _) eqn:Risbitfield. diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 6adcebe5..1cac2257 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -51,9 +51,10 @@ Require Import Floats. Require Import Op. Require Import CminorSel. Require Import OpHelpers. -Require Import ExtValues. +Require Import ExtValues ExtFloats. Require Import DecBoolOps. Require Import Chunks. +Require Import Builtins. Require Compopts. Local Open Scope cminorsel_scope. @@ -65,34 +66,52 @@ Section SELECT. Context {hf: helper_functions}. +Nondetfunction cond_to_condition0 (cond : condition) (args : exprlist) := + match cond, args with + | (Ccompimm c x), (e1 ::: Enil) => + if Int.eq_dec x Int.zero + then Some ((Ccomp0 c), e1) + else None + + | (Ccompuimm c x), (e1 ::: Enil) => + if Int.eq_dec x Int.zero + then Some ((Ccompu0 c), e1) + else None + + | (Ccomplimm c x), (e1 ::: Enil) => + if Int64.eq_dec x Int64.zero + then Some ((Ccompl0 c), e1) + else None + + | (Ccompluimm c x), (e1 ::: Enil) => + if Int64.eq_dec x Int64.zero + then Some ((Ccomplu0 c), e1) + else None + + | _, _ => None + end. + (** Ternary operator *) -Definition select_base o0 o1 oselect := - Eop (Oselect (Ccomp0 Cne)) - (o0:::o1:::oselect:::Enil). - -Definition select o0 o1 oselect := - select_base o0 o1 oselect. - -Definition selectl_base o0 o1 oselect := - Eop (Oselectl (Ccomp0 Cne)) - (o0:::o1:::oselect:::Enil). - -Definition selectl o0 o1 oselect := - selectl_base o0 o1 oselect. - -Definition selectf_base o0 o1 oselect := - Eop (Oselectf (Ccomp0 Cne)) - (o0:::o1:::oselect:::Enil). - -Definition selectf o0 o1 oselect := - selectf_base o0 o1 oselect. - -Definition selectfs_base o0 o1 oselect := - Eop (Oselectfs (Ccomp0 Cne)) - (o0:::o1:::oselect:::Enil). - -Definition selectfs o0 o1 oselect := - selectfs_base o0 o1 oselect. +Nondetfunction select0 (ty : typ) (cond0 : condition0) (e1 e2 e3: expr) := + match ty, cond0, e1, e2, e3 with + | Tint, cond0, e1, (Eop (Ointconst imm) Enil), e3 => + (Eop (Oselimm cond0 imm) (e1 ::: e3 ::: Enil)) + | Tint, cond0, (Eop (Ointconst imm) Enil), e2, e3 => + (Eop (Oselimm (negate_condition0 cond0) imm) (e2 ::: e3 ::: Enil)) + | Tlong, cond0, e1, (Eop (Olongconst imm) Enil), e3 => + (Eop (Osellimm cond0 imm) (e1 ::: e3 ::: Enil)) + | Tlong, cond0, (Eop (Olongconst imm) Enil), e2, e3 => + (Eop (Osellimm (negate_condition0 cond0) imm) (e2 ::: e3 ::: Enil)) + | _, _, _ => (Eop (Osel cond0 ty) (e1 ::: e2 ::: e3 ::: Enil)) + end. + +Definition select (ty : typ) (cond : condition) (args : exprlist) (e1 e2: expr) : option expr := + Some( + match cond_to_condition0 cond args with + | None => select0 ty (Ccomp0 Cne) e1 e2 (Eop (Ocmp cond) args) + | Some(cond0, ec) => select0 ty cond0 e1 e2 ec + end). + (** ** Constants **) @@ -104,6 +123,15 @@ Definition addrstack (ofs: ptrofs) := (** ** Integer addition and pointer addition *) +Definition addimm_shlimm sh k2 e1 := + if Compopts.optim_addx tt + then + match shift1_4_of_z (Int.unsigned sh) with + | Some s14 => Eop (Oaddximm s14 k2) (e1:::Enil) + | None => Eop (Oaddimm k2) ((Eop (Oshlimm sh) (e1:::Enil)):::Enil) + end + else Eop (Oaddimm k2) ((Eop (Oshlimm sh) (e1:::Enil)):::Enil). + Nondetfunction addimm (n: int) (e: expr) := if Int.eq n Int.zero then e else match e with @@ -111,9 +139,20 @@ Nondetfunction addimm (n: int) (e: expr) := | Eop (Oaddrsymbol s m) Enil => Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int n) m)) Enil | Eop (Oaddrstack m) Enil => Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int n) m)) Enil | Eop (Oaddimm m) (t ::: Enil) => Eop (Oaddimm(Int.add n m)) (t ::: Enil) + | Eop (Oaddximm sh m) (t ::: Enil) => Eop (Oaddximm sh (Int.add n m)) (t ::: Enil) + | Eop (Oshlimm sh) (t1:::Enil) => addimm_shlimm sh n t1 | _ => Eop (Oaddimm n) (e ::: Enil) end. +Definition add_shlimm n e1 e2 := + if Compopts.optim_addx tt + then + match shift1_4_of_z (Int.unsigned n) with + | Some s14 => Eop (Oaddx s14) (e1:::e2:::Enil) + | None => Eop Oadd (e2:::(Eop (Oshlimm n) (e1:::Enil)):::Enil) + end + else Eop Oadd (e2:::(Eop (Oshlimm n) (e1:::Enil)):::Enil). + Nondetfunction add (e1: expr) (e2: expr) := match e1, e2 with | Eop (Ointconst n1) Enil, t2 => addimm n1 t2 @@ -135,7 +174,11 @@ Nondetfunction add (e1: expr) (e2: expr) := | t1, (Eop (Omulimm n) (t2:::Enil)) => Eop (Omaddimm n) (t1:::t2:::Enil) | (Eop (Omulimm n) (t2:::Enil)), t1 => - Eop (Omaddimm n) (t1:::t2:::Enil) + Eop (Omaddimm n) (t1:::t2:::Enil) + | (Eop (Oshlimm n) (t1:::Enil)), t2 => + add_shlimm n t1 t2 + | t2, (Eop (Oshlimm n) (t1:::Enil)) => + add_shlimm n t1 t2 | _, _ => Eop Oadd (e1:::e2:::Enil) end. @@ -151,6 +194,10 @@ Nondetfunction sub (e1: expr) (e2: expr) := addimm n1 (Eop Osub (t1:::t2:::Enil)) | t1, Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) + | t1, (Eop Omul (t2:::t3:::Enil)) => + Eop Omsub (t1:::t2:::t3:::Enil) + | t1, (Eop (Omulimm n) (t2:::Enil)) => + Eop (Omaddimm (Int.neg n)) (t1:::t2:::Enil) | _, _ => Eop Osub (e1:::e2:::Enil) end. @@ -321,24 +368,6 @@ Nondetfunction or (e1: expr) (e2: expr) := else Eop Oor (e1:::e2:::Enil) | (Eop Onot (t1:::Enil)), t2 => Eop Oorn (t1:::t2:::Enil) | t1, (Eop Onot (t2:::Enil)) => Eop Oorn (t2:::t1:::Enil) - | (Eop Oand ((Eop Oneg ((Eop (Ocmp (Ccompimm Ceq zero0)) - (y0:::Enil)):::Enil)):::v0:::Enil)), - (Eop Oand ((Eop Oneg ((Eop (Ocmp (Ccompimm Cne zero1)) - (y1:::Enil)):::Enil)):::v1:::Enil)) => - if same_expr_pure y0 y1 - && Int.eq zero0 Int.zero - && Int.eq zero1 Int.zero - then select_base v0 v1 y0 - else Eop Oor (e1:::e2:::Enil) - | (Eop Oand ((Eop Oneg ((Eop (Ocmp (Ccompuimm Ceq zero0)) - (y0:::Enil)):::Enil)):::v0:::Enil)), - (Eop Oand ((Eop Oneg ((Eop (Ocmp (Ccompuimm Cne zero1)) - (y1:::Enil)):::Enil)):::v1:::Enil)) => - if same_expr_pure y0 y1 - && Int.eq zero0 Int.zero - && Int.eq zero1 Int.zero - then select_base v0 v1 y0 - else Eop Oor (e1:::e2:::Enil) | (Eop (Oandimm nmask) (prev:::Enil)), (Eop (Oandimm mask) ((Eop (Oshlimm start) (fld:::Enil)):::Enil)) => @@ -584,18 +613,26 @@ Nondetfunction addressing (chunk: memory_chunk) (e: expr) := match e with | Eop (Oaddrstack n) Enil => (Ainstack n, Enil) | Eop (Oaddrsymbol id ofs) Enil => - (if (orb (Archi.pic_code tt) (negb (Compopts.optim_fglobaladdrtmp tt))) + (if (orb (Archi.pic_code tt) (negb (Compopts.optim_globaladdrtmp tt))) then (Aindexed Ptrofs.zero, e:::Enil) else (Aglobal id ofs, Enil)) | Eop (Oaddimm n) (e1:::Enil) => (Aindexed (Ptrofs.of_int n), e1:::Enil) | Eop (Oaddlimm n) (e1:::Enil) => (Aindexed (Ptrofs.of_int64 n), e1:::Enil) | Eop Oaddl (e1:::(Eop (Oshllimm scale) (e2:::Enil)):::Enil) => - (if Compopts.optim_fxsaddr tt + (if Compopts.optim_xsaddr tt then let zscale := Int.unsigned scale in if Z.eq_dec zscale (zscale_of_chunk chunk) then (Aindexed2XS zscale, e1:::e2:::Enil) else (Aindexed2, e1:::(Eop (Oshllimm scale) (e2:::Enil)):::Enil) else (Aindexed2, e1:::(Eop (Oshllimm scale) (e2:::Enil)):::Enil)) + | Eop (Oaddxl sh) (e1:::e2:::Enil) => + let zscale := ExtValues.z_of_shift1_4 sh in + let scale := Int.repr zscale in + (if Compopts.optim_xsaddr tt + then if Z.eq_dec zscale (zscale_of_chunk chunk) + then (Aindexed2XS zscale, e2:::e1:::Enil) + else (Aindexed2, e2:::(Eop (Oshllimm scale) (e1:::Enil)):::Enil) + else (Aindexed2, e2:::(Eop (Oshllimm scale) (e1:::Enil)):::Enil)) | Eop Oaddl (e1:::e2:::Enil) => (Aindexed2, e1:::e2:::Enil) | _ => (Aindexed Ptrofs.zero, e:::Enil) end. @@ -624,9 +661,45 @@ Definition divf_base (e1: expr) (e2: expr) := (* Eop Odivf (e1 ::: e2 ::: Enil). *) Eexternal f64_div sig_ff_f (e1 ::: e2 ::: Enil). -Definition divfs_base (e1: expr) (e2: expr) := +Definition divfs_base1 (e2 : expr) := + Eop Oinvfs (e2 ::: Enil). +Definition divfs_baseX (e1 : expr) (e2 : expr) := (* Eop Odivf (e1 ::: e2 ::: Enil). *) Eexternal f32_div sig_ss_s (e1 ::: e2 ::: Enil). + +Nondetfunction divfs_base (e1: expr) := + match e1 with + | Eop (Osingleconst f) Enil => + (if Float32.eq_dec f ExtFloat32.one + then divfs_base1 + else divfs_baseX e1) + | _ => divfs_baseX e1 + end. + +Nondetfunction gen_fma args := + match args with + | (Eop Onegf (e1:::Enil)):::e2:::e3:::Enil => Some (Eop Ofmsubf (e3:::e1:::e2:::Enil)) + | e1:::e2:::e3:::Enil => Some (Eop Ofmaddf (e3:::e1:::e2:::Enil)) + | _ => None + end. + +Nondetfunction gen_fmaf args := + match args with + | (Eop Onegfs (e1:::Enil)):::e2:::e3:::Enil => Some (Eop Ofmsubfs (e3:::e1:::e2:::Enil)) + | e1:::e2:::e3:::Enil => Some (Eop Ofmaddfs (e3:::e1:::e2:::Enil)) + | _ => None + end. + +Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr := + match b with + | BI_fmin => Some (Eop Ominf args) + | BI_fmax => Some (Eop Omaxf args) + | BI_fminf => Some (Eop Ominfs args) + | BI_fmaxf => Some (Eop Omaxfs args) + | BI_fabsf => Some (Eop Oabsfs args) + | BI_fma => gen_fma args + | BI_fmaf => gen_fmaf args + end. End SELECT. (* Local Variables: *) diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 22eecfad..6dd00ad5 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -17,6 +17,7 @@ (** Correctness of instruction selection for operators *) +Require Import Builtins. Require Import Coqlib. Require Import Maps. Require Import AST. @@ -29,6 +30,7 @@ Require Import Globalenvs. Require Import Cminor. Require Import Op. Require Import CminorSel. +Require Import Builtins1. Require Import SelectOp. Require Import Events. Require Import OpHelpers. @@ -183,6 +185,75 @@ Proof. auto. Qed. +Theorem eval_addimm_shlimm: + forall sh k2, unary_constructor_sound (addimm_shlimm sh k2) (fun x => ExtValues.addx sh x (Vint k2)). +Proof. + red; unfold addimm_shlimm; intros. + destruct (Compopts.optim_addx tt). + { + destruct (shift1_4_of_z (Int.unsigned sh)) as [s14 |] eqn:SHIFT. + - TrivialExists. simpl. + f_equal. + unfold shift1_4_of_z, int_of_shift1_4, z_of_shift1_4 in *. + destruct (Z.eq_dec _ _) as [e1|]. + { replace s14 with SHIFT1 by congruence. + destruct x; simpl; trivial. + replace (Int.ltu _ _) with true by reflexivity. + unfold Int.ltu. + rewrite e1. + replace (if zlt _ _ then true else false) with true by reflexivity. + rewrite <- e1. + rewrite Int.repr_unsigned. + reflexivity. + } + destruct (Z.eq_dec _ _) as [e2|]. + { replace s14 with SHIFT2 by congruence. + destruct x; simpl; trivial. + replace (Int.ltu _ _) with true by reflexivity. + unfold Int.ltu. + rewrite e2. + replace (if zlt _ _ then true else false) with true by reflexivity. + rewrite <- e2. + rewrite Int.repr_unsigned. + reflexivity. + } + destruct (Z.eq_dec _ _) as [e3|]. + { replace s14 with SHIFT3 by congruence. + destruct x; simpl; trivial. + replace (Int.ltu _ _) with true by reflexivity. + unfold Int.ltu. + rewrite e3. + replace (if zlt _ _ then true else false) with true by reflexivity. + rewrite <- e3. + rewrite Int.repr_unsigned. + reflexivity. + } + destruct (Z.eq_dec _ _) as [e4|]. + { replace s14 with SHIFT4 by congruence. + destruct x; simpl; trivial. + replace (Int.ltu _ _) with true by reflexivity. + unfold Int.ltu. + rewrite e4. + replace (if zlt _ _ then true else false) with true by reflexivity. + rewrite <- e4. + rewrite Int.repr_unsigned. + reflexivity. + } + discriminate. + - unfold addx. rewrite Val.add_commut. + TrivialExists. + repeat (try eassumption; try econstructor). + simpl. + reflexivity. + } + { unfold addx. rewrite Val.add_commut. + TrivialExists. + repeat (try eassumption; try econstructor). + simpl. + reflexivity. + } +Qed. + Theorem eval_addimm: forall n, unary_constructor_sound (addimm n) (fun x => Val.add x (Vint n)). Proof. @@ -198,9 +269,57 @@ Proof. + econstructor; split. EvalOp. simpl; eauto. destruct sp; simpl; auto. + TrivialExists; simpl. subst x. rewrite Val.add_assoc. rewrite Int.add_commut. auto. + + TrivialExists; simpl. subst x. + destruct v1; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. + rewrite Int.add_assoc. rewrite Int.add_commut. + reflexivity. + + pose proof eval_addimm_shlimm as ADDX. + unfold unary_constructor_sound in ADDX. + unfold addx in ADDX. + rewrite Val.add_commut. + subst x. + apply ADDX; assumption. + TrivialExists. Qed. +Lemma eval_addx: forall n, binary_constructor_sound (add_shlimm n) (ExtValues.addx n). +Proof. + red. + intros. + unfold add_shlimm. + destruct (Compopts.optim_addx tt). + { + destruct (shift1_4_of_z (Int.unsigned n)) as [s14 |] eqn:SHIFT. + - TrivialExists. + simpl. + f_equal. f_equal. + unfold shift1_4_of_z, int_of_shift1_4, z_of_shift1_4 in *. + destruct (Z.eq_dec _ _) as [e1|]. + { replace s14 with SHIFT1 by congruence. + rewrite <- e1. + apply Int.repr_unsigned. } + destruct (Z.eq_dec _ _) as [e2|]. + { replace s14 with SHIFT2 by congruence. + rewrite <- e2. + apply Int.repr_unsigned. } + destruct (Z.eq_dec _ _) as [e3|]. + { replace s14 with SHIFT3 by congruence. + rewrite <- e3. + apply Int.repr_unsigned. } + destruct (Z.eq_dec _ _) as [e4|]. + { replace s14 with SHIFT4 by congruence. + rewrite <- e4. + apply Int.repr_unsigned. } + discriminate. + - TrivialExists; + repeat econstructor; eassumption. + } + { TrivialExists; + repeat econstructor; eassumption. + } +Qed. + Theorem eval_add: binary_constructor_sound add Val.add. Proof. red; intros until y. @@ -238,6 +357,15 @@ Proof. subst. TrivialExists. - (* Omaddimm rev *) subst. rewrite Val.add_commut. TrivialExists. + (* Oaddx *) + - subst. pose proof eval_addx as ADDX. + unfold binary_constructor_sound in ADDX. + rewrite Val.add_commut. + apply ADDX; assumption. + (* Oaddx *) + - subst. pose proof eval_addx as ADDX. + unfold binary_constructor_sound in ADDX. + apply ADDX; assumption. - TrivialExists. Qed. @@ -251,6 +379,12 @@ Proof. apply eval_addimm; EvalOp. - subst. rewrite Val.sub_add_l. apply eval_addimm; EvalOp. - subst. rewrite Val.sub_add_r. apply eval_addimm; EvalOp. + - TrivialExists. simpl. subst. reflexivity. + - TrivialExists. simpl. subst. + rewrite sub_add_neg. + rewrite neg_mul_distr_r. + unfold Val.neg. + reflexivity. - TrivialExists. Qed. @@ -477,7 +611,7 @@ Proof. change (Int.ltu (Int.repr 32) Int64.iwordsize') with true; simpl. apply Val.lessdef_same. f_equal. transitivity (Int.repr (Z.shiftr (Int.signed i * Int.signed i0) 32)). - unfold Int.mulhs; f_equal. rewrite Int.Zshiftr_div_two_p by omega. reflexivity. + unfold Int.mulhs; f_equal. rewrite Zbits.Zshiftr_div_two_p by omega. reflexivity. apply Int.same_bits_eq; intros n N. change Int.zwordsize with 32 in *. assert (N1: 0 <= n < 64) by omega. @@ -505,7 +639,7 @@ Proof. change (Int.ltu (Int.repr 32) Int64.iwordsize') with true; simpl. apply Val.lessdef_same. f_equal. transitivity (Int.repr (Z.shiftr (Int.unsigned i * Int.unsigned i0) 32)). - unfold Int.mulhu; f_equal. rewrite Int.Zshiftr_div_two_p by omega. reflexivity. + unfold Int.mulhu; f_equal. rewrite Zbits.Zshiftr_div_two_p by omega. reflexivity. apply Int.same_bits_eq; intros n N. change Int.zwordsize with 32 in *. assert (N1: 0 <= n < 64) by omega. @@ -624,83 +758,6 @@ Proof. exists (Val.ror v1 (Vint n2)); split. EvalOp. rewrite Val.or_commut. apply ROR; auto. - (*orn*) TrivialExists; simpl; congruence. - (*orn reversed*) rewrite Val.or_commut. TrivialExists; simpl; congruence. - - (* select *) - destruct (same_expr_pure y0 y1) eqn:PURE; simpl; try exact DEFAULT. - predSpec Int.eq Int.eq_spec zero0 Int.zero; simpl; try exact DEFAULT. - predSpec Int.eq Int.eq_spec zero1 Int.zero; simpl; try exact DEFAULT. - TrivialExists. - simpl in *. - unfold eval_select. - f_equal. - inv H6. - inv H7. - inv H9. - inv H11. - unfold same_expr_pure in PURE. - destruct y0; try congruence. - destruct y1; try congruence. - destruct (ident_eq i i0); try congruence. - rewrite <- e0 in *. clear e0. clear PURE. - inv H2. inv H5. - replace v8 with v4 in * by congruence. - rename v4 into vselect. - destruct vselect; simpl; trivial; - destruct v5; simpl; trivial; destruct v9; simpl; trivial; - destruct (Int.eq i1 Int.zero); simpl; trivial. - + rewrite Int.neg_zero. - rewrite Int.and_commut. - rewrite Int.and_mone. - rewrite Int.and_commut. - rewrite Int.and_zero. - rewrite Int.or_zero. - reflexivity. - + rewrite Int.neg_zero. - rewrite Int.and_commut. - rewrite Int.and_zero. - rewrite Int.and_commut. - rewrite Int.and_mone. - rewrite Int.or_commut. - rewrite Int.or_zero. - reflexivity. - - (* select unsigned *) - destruct (same_expr_pure y0 y1) eqn:PURE; simpl; try exact DEFAULT. - predSpec Int.eq Int.eq_spec zero0 Int.zero; simpl; try exact DEFAULT. - predSpec Int.eq Int.eq_spec zero1 Int.zero; simpl; try exact DEFAULT. - TrivialExists. - simpl in *. - unfold eval_select. - f_equal. - inv H6. - inv H7. - inv H9. - inv H11. - unfold same_expr_pure in PURE. - destruct y0; try congruence. - destruct y1; try congruence. - destruct (ident_eq i i0); try congruence. - rewrite <- e0 in *. clear e0. clear PURE. - inv H2. inv H5. - replace v8 with v4 in * by congruence. - rename v4 into vselect. - destruct vselect; simpl; trivial; - destruct v5; simpl; trivial; - destruct v9; simpl; trivial; - destruct (Int.eq i1 Int.zero); simpl; trivial. - + rewrite Int.neg_zero. - rewrite Int.and_commut. - rewrite Int.and_mone. - rewrite Int.and_commut. - rewrite Int.and_zero. - rewrite Int.or_zero. - reflexivity. - + rewrite Int.neg_zero. - rewrite Int.and_commut. - rewrite Int.and_zero. - rewrite Int.and_commut. - rewrite Int.and_mone. - rewrite Int.or_commut. - rewrite Int.or_zero. - reflexivity. - set (zstop := (int_highest_bit mask)). set (zstart := (Int.unsigned start)). destruct (is_bitfield _ _) eqn:Risbitfield. @@ -1161,7 +1218,8 @@ Qed. Theorem eval_cast8unsigned: unary_constructor_sound cast8unsigned (Val.zero_ext 8). Proof. red; intros until x. unfold cast8unsigned. - rewrite Val.zero_ext_and. apply eval_andimm. compute; auto. + + rewrite Val.zero_ext_and. apply eval_andimm. compute; auto. discriminate. Qed. Theorem eval_cast16signed: unary_constructor_sound cast16signed (Val.sign_ext 16). @@ -1174,7 +1232,7 @@ Qed. Theorem eval_cast16unsigned: unary_constructor_sound cast16unsigned (Val.zero_ext 16). Proof. red; intros until x. unfold cast8unsigned. - rewrite Val.zero_ext_and. apply eval_andimm. compute; auto. + rewrite Val.zero_ext_and. apply eval_andimm. compute; auto. discriminate. Qed. Theorem eval_intoffloat: @@ -1311,7 +1369,7 @@ Proof. - exists (v1 :: nil); split. eauto with evalexpr. simpl. destruct v1; simpl in H; try discriminate. destruct Archi.ptr64 eqn:SF; inv H. simpl. auto. - - destruct (Compopts.optim_fxsaddr tt). + - destruct (Compopts.optim_xsaddr tt). + destruct (Z.eq_dec _ _). * exists (v1 :: v2 :: nil); split. repeat (constructor; auto). simpl. rewrite Int.repr_unsigned. destruct v2; simpl in *; congruence. @@ -1323,6 +1381,25 @@ Proof. repeat (constructor; auto). econstructor. repeat (constructor; auto). eassumption. simpl. congruence. simpl. congruence. + - unfold addxl in *. + destruct (Compopts.optim_xsaddr tt). + + unfold int_of_shift1_4 in *. + destruct (Z.eq_dec _ _). + * exists (v0 :: v1 :: nil); split. + repeat (constructor; auto). simpl. + congruence. + * eexists; split. + repeat (constructor; auto). eassumption. + econstructor. + repeat (constructor; auto). eassumption. simpl. + reflexivity. + simpl. congruence. + + eexists; split. + repeat (constructor; auto). eassumption. + econstructor. + repeat (constructor; auto). eassumption. simpl. + reflexivity. + simpl. unfold int_of_shift1_4 in *. congruence. - exists (v1 :: v0 :: nil); split. repeat (constructor; auto). simpl. congruence. - exists (v :: nil); split. eauto with evalexpr. subst. simpl. rewrite Ptrofs.add_zero; auto. Qed. @@ -1351,6 +1428,204 @@ Proof. - constructor; auto. Qed. +(* ternary *) +(* does not work due to possible nondeterminism +Lemma cond_to_condition0_correct : + forall cond : condition, + forall al : exprlist, + match (cond_to_condition0 cond al) with + | None => True + | Some(cond0, e1) => + forall le vl v1, + eval_expr ge sp e m le e1 v1 -> + eval_exprlist ge sp e m le al vl -> + (eval_condition0 cond0 v1 m) = (eval_condition cond vl m) + end. +Proof. + intros. + unfold cond_to_condition0. + case (cond_to_condition0_match cond al); trivial. + { + intros. + destruct (Int.eq_dec _ _); trivial. + intros until v1. + intros He1 Hel. + InvEval. + simpl. + f_equal. + eapply eval_expr_determ. eassumption. + } +Qed. +*) + +Lemma eval_neg_condition0: + forall cond0: condition0, + forall v1: val, + forall m: mem, + (eval_condition0 (negate_condition0 cond0) v1 m) = + option_map negb (eval_condition0 cond0 v1 m). +Proof. + intros. + destruct cond0; simpl; + try rewrite Val.negate_cmp_bool; + try rewrite Val.negate_cmpu_bool; + try rewrite Val.negate_cmpl_bool; + try rewrite Val.negate_cmplu_bool; + reflexivity. +Qed. + +Lemma select_neg: + forall a b c, + Val.select (option_map negb a) b c = + Val.select a c b. +Proof. + destruct a; simpl; trivial. + destruct b; simpl; trivial. +Qed. + +Lemma eval_select0: + forall le ty cond0 ac vc a1 v1 a2 v2, + eval_expr ge sp e m le ac vc -> + eval_expr ge sp e m le a1 v1 -> + eval_expr ge sp e m le a2 v2 -> + exists v, + eval_expr ge sp e m le (select0 ty cond0 a1 a2 ac) v + /\ Val.lessdef (Val.select (eval_condition0 cond0 vc m) v1 v2 ty) v. +Proof. + intros. + unfold select0. + destruct (select0_match ty cond0 a1 a2 ac). + all: InvEval; econstructor; split; + try repeat (try econstructor; try eassumption). + all: rewrite eval_neg_condition0; rewrite select_neg; constructor. +Qed. + +Lemma bool_cond0_ne: + forall ob : option bool, + forall m, + (eval_condition0 (Ccomp0 Cne) (Val.of_optbool ob) m) = ob. +Proof. + destruct ob; simpl; trivial. + intro. + destruct b; reflexivity. +Qed. + +Lemma eval_condition_ccomp_swap : + forall c x y m, + eval_condition (Ccomp (swap_comparison c)) (x :: y :: nil) m= + eval_condition (Ccomp c) (y :: x :: nil) m. +Proof. + intros; unfold eval_condition; + apply Val.swap_cmp_bool. +Qed. + +Lemma eval_condition_ccompu_swap : + forall c x y m, + eval_condition (Ccompu (swap_comparison c)) (x :: y :: nil) m= + eval_condition (Ccompu c) (y :: x :: nil) m. +Proof. + intros; unfold eval_condition; + apply Val.swap_cmpu_bool. +Qed. + +Lemma eval_condition_ccompl_swap : + forall c x y m, + eval_condition (Ccompl (swap_comparison c)) (x :: y :: nil) m= + eval_condition (Ccompl c) (y :: x :: nil) m. +Proof. + intros; unfold eval_condition; + apply Val.swap_cmpl_bool. +Qed. + +Lemma eval_condition_ccomplu_swap : + forall c x y m, + eval_condition (Ccomplu (swap_comparison c)) (x :: y :: nil) m= + eval_condition (Ccomplu c) (y :: x :: nil) m. +Proof. + intros; unfold eval_condition; + apply Val.swap_cmplu_bool. +Qed. + +Theorem eval_select: + forall le ty cond al vl a1 v1 a2 v2 a b, + select ty cond al a1 a2 = Some a -> + eval_exprlist ge sp e m le al vl -> + eval_expr ge sp e m le a1 v1 -> + eval_expr ge sp e m le a2 v2 -> + eval_condition cond vl m = Some b -> + exists v, + eval_expr ge sp e m le a v + /\ Val.lessdef (Val.select (Some b) v1 v2 ty) v. +Proof. + unfold select. + intros until b. + intro Hop; injection Hop; clear Hop; intro; subst a. + intros HeL He1 He2 HeC. + unfold cond_to_condition0. + destruct (cond_to_condition0_match cond al). + { + InvEval. + rewrite <- HeC. + destruct (Int.eq_dec x Int.zero). + { subst x. + simpl. + change (Val.cmp_bool c v0 (Vint Int.zero)) + with (eval_condition0 (Ccomp0 c) v0 m). + eapply eval_select0; eassumption. + } + simpl. + erewrite <- (bool_cond0_ne (Val.cmp_bool c v0 (Vint x))). + eapply eval_select0; repeat (try econstructor; try eassumption). + } + { + InvEval. + rewrite <- HeC. + destruct (Int.eq_dec x Int.zero). + { subst x. + simpl. + change (Val.cmpu_bool (Mem.valid_pointer m) c v0 (Vint Int.zero)) + with (eval_condition0 (Ccompu0 c) v0 m). + eapply eval_select0; eassumption. + } + simpl. + erewrite <- (bool_cond0_ne (Val.cmpu_bool (Mem.valid_pointer m) c v0 (Vint x))). + eapply eval_select0; repeat (try econstructor; try eassumption). + } + { + InvEval. + rewrite <- HeC. + destruct (Int64.eq_dec x Int64.zero). + { subst x. + simpl. + change (Val.cmpl_bool c v0 (Vlong Int64.zero)) + with (eval_condition0 (Ccompl0 c) v0 m). + eapply eval_select0; eassumption. + } + simpl. + erewrite <- (bool_cond0_ne (Val.cmpl_bool c v0 (Vlong x))). + eapply eval_select0; repeat (try econstructor; try eassumption). + } + { + InvEval. + rewrite <- HeC. + destruct (Int64.eq_dec x Int64.zero). + { subst x. + simpl. + change (Val.cmplu_bool (Mem.valid_pointer m) c v0 (Vlong Int64.zero)) + with (eval_condition0 (Ccomplu0 c) v0 m). + eapply eval_select0; eassumption. + } + simpl. + erewrite <- (bool_cond0_ne (Val.cmplu_bool (Mem.valid_pointer m) c v0 (Vlong x))). + eapply eval_select0; repeat (try econstructor; try eassumption). + } + erewrite <- (bool_cond0_ne (Some b)). + eapply eval_select0; repeat (try econstructor; try eassumption). + rewrite <- HeC. + simpl. + reflexivity. +Qed. + (* floating-point division *) Theorem eval_divf_base: forall le a b x y, @@ -1362,6 +1637,29 @@ Proof. econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. Qed. + +Lemma eval_divfs_base1: + forall le a b x 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 (divfs_base1 b) v /\ Val.lessdef (ExtValues.invfs y) v. +Proof. + intros; unfold divfs_base1. + econstructor; split. + repeat (try econstructor; try eassumption). + trivial. +Qed. + +Lemma eval_divfs_baseX: + forall le a b x 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 (divfs_baseX a b) v /\ Val.lessdef (Val.divfs x y) v. +Proof. + intros; unfold divfs_base. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. +Qed. + Theorem eval_divfs_base: forall le a b x y, eval_expr ge sp e m le a x -> @@ -1369,6 +1667,82 @@ Theorem eval_divfs_base: exists v, eval_expr ge sp e m le (divfs_base a b) v /\ Val.lessdef (Val.divfs x y) v. Proof. intros; unfold divfs_base. - econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. + destruct (divfs_base_match _). + - destruct (Float32.eq_dec _ _). + + exists (Val.divfs x y). + split; trivial. repeat (try econstructor; try eassumption). + simpl. InvEval. reflexivity. + + apply eval_divfs_baseX; assumption. + - apply eval_divfs_baseX; assumption. +Qed. + +(** Platform-specific known builtins *) + +Lemma eval_fma: + forall al a vl v le, + gen_fma al = Some a -> + eval_exprlist ge sp e m le al vl -> + platform_builtin_sem BI_fma vl = Some v -> + exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'. +Proof. + unfold gen_fma. + intros until le. + intro Heval. + destruct (gen_fma_match _) in *; try discriminate. + all: inversion Heval; subst a; clear Heval; intro; InvEval. + - subst v1. + TrivialExists. + destruct v0; simpl; trivial; + destruct v2; simpl; trivial; + destruct v3; simpl; trivial. + - intro Heval. + simpl in Heval. + inv Heval. + TrivialExists. + destruct v0; simpl; trivial; + destruct v1; simpl; trivial; + destruct v2; simpl; trivial. +Qed. + +Lemma eval_fmaf: + forall al a vl v le, + gen_fmaf al = Some a -> + eval_exprlist ge sp e m le al vl -> + platform_builtin_sem BI_fmaf vl = Some v -> + exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'. +Proof. + unfold gen_fmaf. + intros until le. + intro Heval. + destruct (gen_fmaf_match _) in *; try discriminate. + all: inversion Heval; subst a; clear Heval; intro; InvEval. + - subst v1. + TrivialExists. + destruct v0; simpl; trivial; + destruct v2; simpl; trivial; + destruct v3; simpl; trivial. + - intro Heval. + simpl in Heval. + inv Heval. + TrivialExists. + destruct v0; simpl; trivial; + destruct v1; simpl; trivial; + destruct v2; simpl; trivial. +Qed. + +Theorem eval_platform_builtin: + forall bf al a vl v le, + platform_builtin bf al = Some a -> + eval_exprlist ge sp e m le al vl -> + platform_builtin_sem bf vl = Some v -> + exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'. +Proof. + destruct bf; intros until le; intro Heval. + all: try (inversion Heval; subst a; clear Heval; + exists v; split; trivial; + repeat (try econstructor; try eassumption)). + - apply eval_fma; assumption. + - apply eval_fmaf; assumption. Qed. + End CMCONSTR. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 2bdd0978..63a0bd24 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -64,7 +64,7 @@ module Target (*: TARGET*) = | "__compcert_i64_smod" -> (match idiv_function_kind_64bit() with | Idiv_system | Idiv_fp -> "__moddi3" - | Idiv_stsud -> "__compcert_i64_stsud") + | Idiv_stsud -> "__compcert_i64_smod_stsud") | "__compcert_i32_sdiv" as s -> (match idiv_function_kind_32bit() with | Idiv_system -> s @@ -186,11 +186,19 @@ module Target (*: TARGET*) = | RA -> output_string oc "$ra" | _ -> assert false + let preg_asm oc ty = preg oc + let preg_annot = let open Asmvliw in function | IR r -> int_reg_name r | RA -> "$ra" | _ -> assert false + let scale_of_shift1_4 = let open ExtValues in function + | SHIFT1 -> 2 + | SHIFT2 -> 4 + | SHIFT3 -> 8 + | SHIFT4 -> 16;; + (* Names of sections *) let name_of_section = function @@ -289,6 +297,10 @@ module Target (*: TARGET*) = | ARegXS _ -> fprintf oc ".xs" | _ -> () + let lsvariant oc = function + | TRAP -> () + | NOTRAP -> output_string oc ".s" + let icond_name = let open Asmvliw in function | ITne | ITneu -> "ne" | ITeq | ITequ -> "eq" @@ -300,10 +312,6 @@ module Target (*: TARGET*) = | ITgeu -> "geu" | ITleu -> "leu" | ITgtu -> "gtu" - | ITall -> "all" - | ITnall -> "nall" - | ITany -> "any" - | ITnone -> "none" let icond oc c = fprintf oc "%s" (icond_name c) @@ -364,7 +372,7 @@ module Target (*: TARGET*) = (P.to_int kind) (extern_atom txt) args | EF_inline_asm(txt, sg, clob) -> fprintf oc "%s begin inline assembly\n\t" comment; - print_inline_asm preg oc (camlstring_of_coqstring txt) sg args res; + print_inline_asm preg_asm oc (camlstring_of_coqstring txt) sg args res; fprintf oc "%s end inline assembly\n" comment | _ -> assert false @@ -439,10 +447,10 @@ module Target (*: TARGET*) = fprintf oc " itouchl 0[%a]\n" ireg addr | Pdzerol addr -> fprintf oc " dzerol 0[%a]\n" ireg addr - | Pafaddd(addr, incr_res) -> - fprintf oc " afaddd 0[%a] = %a\n" ireg addr ireg incr_res +(* | Pafaddd(addr, incr_res) -> + fprintfoc " afaddd 0[%a] = %a\n" ireg addr ireg incr_res | Pafaddw(addr, incr_res) -> - fprintf oc " afaddw 0[%a] = %a\n" ireg addr ireg incr_res + fprintfoc " afaddw 0[%a] = %a\n" ireg addr ireg incr_res *) (* see #157 *) | Palclrd(res, addr) -> fprintf oc " alclrd %a = 0[%a]\n" ireg res ireg addr | Palclrw(res, addr) -> @@ -462,18 +470,18 @@ module Target (*: TARGET*) = section oc Section_text (* Load/Store instructions *) - | Plb(rd, ra, adr) -> - fprintf oc " lbs%a %a = %a[%a]\n" xscale adr ireg rd addressing adr ireg ra - | Plbu(rd, ra, adr) -> - fprintf oc " lbz%a %a = %a[%a]\n" xscale adr ireg rd addressing adr ireg ra - | Plh(rd, ra, adr) -> - fprintf oc " lhs%a %a = %a[%a]\n" xscale adr ireg rd addressing adr ireg ra - | Plhu(rd, ra, adr) -> - fprintf oc " lhz%a %a = %a[%a]\n" xscale adr ireg rd addressing adr ireg ra - | Plw(rd, ra, adr) | Plw_a(rd, ra, adr) | Pfls(rd, ra, adr) -> - fprintf oc " lws%a %a = %a[%a]\n" xscale adr ireg rd addressing adr ireg ra - | Pld(rd, ra, adr) | Pfld(rd, ra, adr) | Pld_a(rd, ra, adr) -> assert Archi.ptr64; - fprintf oc " ld%a %a = %a[%a]\n" xscale adr ireg rd addressing adr ireg ra + | Plb(trap, rd, ra, adr) -> + fprintf oc " lbs%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra + | Plbu(trap, rd, ra, adr) -> + fprintf oc " lbz%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra + | Plh(trap, rd, ra, adr) -> + fprintf oc " lhs%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra + | Plhu(trap, rd, ra, adr) -> + fprintf oc " lhz%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra + | Plw(trap, rd, ra, adr) | Plw_a(trap, rd, ra, adr) | Pfls(trap, rd, ra, adr) -> + fprintf oc " lws%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra + | Pld(trap, rd, ra, adr) | Pfld(trap, rd, ra, adr) | Pld_a(trap, rd, ra, adr) -> assert Archi.ptr64; + fprintf oc " ld%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra | Plq(rd, ra, adr) -> fprintf oc " lq%a %a = %a[%a]\n" xscale adr gpreg_q rd addressing adr ireg ra | Plo(rd, ra, adr) -> @@ -574,8 +582,14 @@ module Target (*: TARGET*) = | Paddw (rd, rs1, rs2) -> fprintf oc " addw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Paddxw (s14, rd, rs1, rs2) -> + fprintf oc " addx%dw %a = %a, %a\n" (scale_of_shift1_4 s14) + ireg rd ireg rs1 ireg rs2 | Psubw (rd, rs1, rs2) -> fprintf oc " sbfw %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 + | Prevsubxw (s14, rd, rs1, rs2) -> + fprintf oc " sbfx%dw %a = %a, %a\n" (scale_of_shift1_4 s14) + ireg rd ireg rs1 ireg rs2 | Pmulw (rd, rs1, rs2) -> fprintf oc " mulw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pandw (rd, rs1, rs2) -> @@ -604,22 +618,34 @@ module Target (*: TARGET*) = fprintf oc " sllw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pmaddw (rd, rs1, rs2) -> fprintf oc " maddw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - - | Paddl (rd, rs1, rs2) -> assert Archi.ptr64; + | Pmsubw (rd, rs1, rs2) -> + fprintf oc " msbfw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfmaddfw (rd, rs1, rs2) -> + fprintf oc " ffmaw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfmsubfw (rd, rs1, rs2) -> + fprintf oc " ffmsw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + + | Paddl (rd, rs1, rs2) -> fprintf oc " addd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Paddxl (s14, rd, rs1, rs2) -> + fprintf oc " addx%dd %a = %a, %a\n" (scale_of_shift1_4 s14) + ireg rd ireg rs1 ireg rs2 | Psubl (rd, rs1, rs2) -> fprintf oc " sbfd %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 - | Pandl (rd, rs1, rs2) -> assert Archi.ptr64; + | Prevsubxl (s14, rd, rs1, rs2) -> + fprintf oc " sbfx%dd %a = %a, %a\n" (scale_of_shift1_4 s14) + ireg rd ireg rs1 ireg rs2 + | Pandl (rd, rs1, rs2) -> fprintf oc " andd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pnandl (rd, rs1, rs2) -> assert Archi.ptr64; + | Pnandl (rd, rs1, rs2) -> fprintf oc " nandd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Porl (rd, rs1, rs2) -> assert Archi.ptr64; + | Porl (rd, rs1, rs2) -> fprintf oc " ord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pnorl (rd, rs1, rs2) -> assert Archi.ptr64; + | Pnorl (rd, rs1, rs2) -> fprintf oc " nord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pxorl (rd, rs1, rs2) -> assert Archi.ptr64; + | Pxorl (rd, rs1, rs2) -> fprintf oc " xord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pnxorl (rd, rs1, rs2) -> assert Archi.ptr64; + | Pnxorl (rd, rs1, rs2) -> fprintf oc " nxord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pandnl (rd, rs1, rs2) -> fprintf oc " andnd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 @@ -637,6 +663,12 @@ module Target (*: TARGET*) = fprintf oc " srad %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pmaddl (rd, rs1, rs2) -> fprintf oc " maddd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pmsubl (rd, rs1, rs2) -> + fprintf oc " msbfd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfmaddfl (rd, rs1, rs2) -> + fprintf oc " ffmad %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfmsubfl (rd, rs1, rs2) -> + fprintf oc " ffmsd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pfaddd (rd, rs1, rs2) -> fprintf oc " faddd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 @@ -650,12 +682,30 @@ module Target (*: TARGET*) = fprintf oc " fmuld %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pfmulw (rd, rs1, rs2) -> fprintf oc " fmulw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfmind (rd, rs1, rs2) -> + fprintf oc " fmind %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfminw (rd, rs1, rs2) -> + fprintf oc " fminw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfmaxd (rd, rs1, rs2) -> + fprintf oc " fmaxd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfmaxw (rd, rs1, rs2) -> + fprintf oc " fmaxw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfinvw (rd, rs1) -> + fprintf oc " finvw %a = %a\n" ireg rd ireg rs1 (* Arith RRI32 instructions *) | Pcompiw (it, rd, rs, imm) -> fprintf oc " compw.%a %a = %a, %a\n" icond it ireg rd ireg rs coqint imm | Paddiw (rd, rs, imm) -> fprintf oc " addw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Paddxiw (s14, rd, rs, imm) -> + fprintf oc " addx%dw %a = %a, %a\n" (scale_of_shift1_4 s14) + ireg rd ireg rs coqint imm + | Prevsubiw (rd, rs, imm) -> + fprintf oc " sbfw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Prevsubxiw (s14, rd, rs, imm) -> + fprintf oc " sbfx%dw %a = %a, %a\n" (scale_of_shift1_4 s14) + ireg rd ireg rs coqint imm | Pmuliw (rd, rs, imm) -> fprintf oc " mulw %a = %a, %a\n" ireg rd ireg rs coqint imm | Pandiw (rd, rs, imm) -> @@ -701,6 +751,14 @@ module Target (*: TARGET*) = fprintf oc " compd.%a %a = %a, %a\n" icond it ireg rd ireg rs coqint64 imm | Paddil (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " addd %a = %a, %a\n" ireg rd ireg rs coqint64 imm + | Paddxil (s14, rd, rs, imm) -> + fprintf oc " addx%dd %a = %a, %a\n" (scale_of_shift1_4 s14) + ireg rd ireg rs coqint imm + | Prevsubil (rd, rs, imm) -> + fprintf oc " sbfd %a = %a, %a\n" ireg rd ireg rs coqint64 imm + | Prevsubxil (s14, rd, rs, imm) -> + fprintf oc " sbfx%dd %a = %a, %a\n" (scale_of_shift1_4 s14) + ireg rd ireg rs coqint64 imm | Pmulil (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " muld %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pandil (rd, rs, imm) -> assert Archi.ptr64; @@ -725,6 +783,12 @@ module Target (*: TARGET*) = | Pcmove (bt, rd, rcond, rs) | Pcmoveu (bt, rd, rcond, rs) -> fprintf oc " cmoved.%a %a? %a = %a\n" bcond bt ireg rcond ireg rd ireg rs + | Pcmoveiw (bt, rd, rcond, imm) | Pcmoveuiw (bt, rd, rcond, imm) -> + fprintf oc " cmoved.%a %a? %a = %a\n" + bcond bt ireg rcond ireg rd coqint imm + | Pcmoveil (bt, rd, rcond, imm) | Pcmoveuil (bt, rd, rcond, imm) -> + fprintf oc " cmoved.%a %a? %a = %a\n" + bcond bt ireg rcond ireg rd coqint64 imm let get_section_names name = let (text, lit) = diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 643cca0c..7d84447e 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -12,7 +12,37 @@ Require Import Coqlib Compopts. Require Import AST Integers Floats Values Memory Globalenvs. -Require Import Op ExtValues RTL ValueDomain. +Require Import Op ExtValues ExtFloats RTL ValueDomain. + +Definition minf := binop_float ExtFloat.min. +Definition maxf := binop_float ExtFloat.max. +Definition minfs := binop_single ExtFloat32.min. +Definition maxfs := binop_single ExtFloat32.max. + +Definition ntop3 (x y z: aval) : aval := Ifptr (plub (provenance x) (plub (provenance y) (provenance z))). + +Definition triple_op_float (sem: float -> float -> float -> float) (x y z: aval) := + match x, y, z with + | F a, F b, F c => F (sem a b c) + | _, _, _ => ntop3 x y z + end. + +Definition triple_op_single (sem: float32 -> float32 -> float32 -> float32) (x y z: aval) := + match x, y, z with + | FS a, FS b, FS c => FS (sem a b c) + | _, _, _ => ntop3 x y z + end. + +Definition fmaddf := triple_op_float (fun x y z => Float.fma y z x). +Definition fmsubf := triple_op_float (fun x y z => Float.fma (Float.neg y) z x). +Definition fmaddfs := triple_op_single (fun x y z => Float32.fma y z x). +Definition fmsubfs := triple_op_single (fun x y z => Float32.fma (Float32.neg y) z x). + +Definition invfs (y : aval) := + match y with + | FS f => FS (ExtFloat32.inv f) + | _ => ntop1 y + end. (** Value analysis for RISC V operators *) @@ -51,30 +81,6 @@ Definition eval_static_condition0 (cond : condition0) (v : aval) : abool := | Ccomplu0 c => cmplu_bool c v (L Int64.zero) end. -Definition eval_static_select (cond : condition0) (v0 v1 vselect : aval) : aval := - match eval_static_condition0 cond vselect with - | Just b => binop_int (fun x0 x1 => if b then x1 else x0) v0 v1 - | _ => Vtop - end. - -Definition eval_static_selectl (cond : condition0) (v0 v1 vselect : aval) : aval := - match eval_static_condition0 cond vselect with - | Just b => binop_long (fun x0 x1 => if b then x1 else x0) v0 v1 - | _ => Vtop - end. - -Definition eval_static_selectf (cond : condition0) (v0 v1 vselect : aval) : aval := - match eval_static_condition0 cond vselect with - | Just b => binop_float (fun x0 x1 => if b then x1 else x0) v0 v1 - | _ => Vtop - end. - -Definition eval_static_selectfs (cond : condition0) (v0 v1 vselect : aval) : aval := - match eval_static_condition0 cond vselect with - | Just b => binop_single (fun x0 x1 => if b then x1 else x0) v0 v1 - | _ => Vtop - end. - Definition eval_static_extfs (stop : Z) (start : Z) (v : aval) := if is_bitfield stop start @@ -161,8 +167,13 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Ocast16signed, v1 :: nil => sign_ext 16 v1 | Oadd, v1::v2::nil => add v1 v2 | Oaddimm n, v1::nil => add v1 (I n) + | Oaddx shift, v1::v2::nil => add v2 (shl v1 (I (int_of_shift1_4 shift))) + | Oaddximm shift n, v1::nil => add (I n) (shl v1 (I (int_of_shift1_4 shift))) | Oneg, v1::nil => neg v1 | Osub, v1::v2::nil => sub v1 v2 + | Orevsubx shift, v1::v2::nil => sub v2 (shl v1 (I (int_of_shift1_4 shift))) + | Orevsubimm n, v1::nil => sub (I n) v1 + | Orevsubximm shift n, v1::nil => sub (I n) (shl v1 (I (int_of_shift1_4 shift))) | Omul, v1::v2::nil => mul v1 v2 | Omulimm n, v1::nil => mul v1 (I n) | Omulhs, v1::v2::nil => mulhs v1 v2 @@ -198,6 +209,7 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Oshrximm n, v1::nil => shrx v1 (I n) | Omadd, v1::v2::v3::nil => add v1 (mul v2 v3) | Omaddimm n, v1::v2::nil => add v1 (mul v2 (I n)) + | Omsub, v1::v2::v3::nil => sub v1 (mul v2 v3) | Omakelong, v1::v2::nil => longofwords v1 v2 | Olowlong, v1::nil => loword v1 | Ohighlong, v1::nil => hiword v1 @@ -205,8 +217,13 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Ocast32unsigned, v1::nil => longofintu v1 | Oaddl, v1::v2::nil => addl v1 v2 | Oaddlimm n, v1::nil => addl v1 (L n) + | Oaddxl shift, v1::v2::nil => addl v2 (shll v1 (I (int_of_shift1_4 shift))) + | Oaddxlimm shift n, v1::nil => addl (L n) (shll v1 (I (int_of_shift1_4 shift))) | Onegl, v1::nil => negl v1 | Osubl, v1::v2::nil => subl v1 v2 + | Orevsubxl shift, v1::v2::nil => subl v2 (shll v1 (I (int_of_shift1_4 shift))) + | Orevsublimm n, v1::nil => subl (L n) v1 + | Orevsubxlimm shift n, v1::nil => subl (L n) (shll v1 (I (int_of_shift1_4 shift))) | Omull, v1::v2::nil => mull v1 v2 | Omullimm n, v1::nil => mull v1 (L n) | Omullhs, v1::v2::nil => mullhs v1 v2 @@ -241,18 +258,28 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Oshrxlimm n, v1::nil => shrxl v1 (I n) | Omaddl, v1::v2::v3::nil => addl v1 (mull v2 v3) | Omaddlimm n, v1::v2::nil => addl v1 (mull v2 (L n)) + | Omsubl, v1::v2::v3::nil => subl v1 (mull v2 v3) | Onegf, v1::nil => negf v1 | Oabsf, v1::nil => absf v1 | Oaddf, v1::v2::nil => addf v1 v2 | Osubf, v1::v2::nil => subf v1 v2 | Omulf, v1::v2::nil => mulf v1 v2 | Odivf, v1::v2::nil => divf v1 v2 + | Ominf, v1::v2::nil => minf v1 v2 + | Omaxf, v1::v2::nil => maxf v1 v2 + | Ofmaddf, v1::v2::v3::nil => fmaddf v1 v2 v3 + | Ofmsubf, v1::v2::v3::nil => fmsubf v1 v2 v3 | Onegfs, v1::nil => negfs v1 | Oabsfs, v1::nil => absfs v1 | Oaddfs, v1::v2::nil => addfs v1 v2 | Osubfs, v1::v2::nil => subfs v1 v2 | Omulfs, v1::v2::nil => mulfs v1 v2 | Odivfs, v1::v2::nil => divfs v1 v2 + | Ominfs, v1::v2::nil => minfs v1 v2 + | Omaxfs, v1::v2::nil => maxfs v1 v2 + | Oinvfs, v1::nil => invfs v1 + | Ofmaddfs, v1::v2::v3::nil => fmaddfs v1 v2 v3 + | Ofmsubfs, v1::v2::v3::nil => fmsubfs v1 v2 v3 | Osingleoffloat, v1::nil => singleoffloat v1 | Ofloatofsingle, v1::nil => floatofsingle v1 | Ointoffloat, v1::nil => intoffloat v1 @@ -270,16 +297,15 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Osingleoflong, v1::nil => singleoflong v1 | Osingleoflongu, v1::nil => singleoflongu v1 | Ocmp c, _ => of_optbool (eval_static_condition c vl) - | (Oselect cond), v0::v1::vselect::nil => eval_static_select cond v0 v1 vselect - | (Oselectl cond), v0::v1::vselect::nil => eval_static_selectl cond v0 v1 vselect - | (Oselectf cond), v0::v1::vselect::nil => eval_static_selectf cond v0 v1 vselect - | (Oselectfs cond), v0::v1::vselect::nil => eval_static_selectfs cond v0 v1 vselect | (Oextfz stop start), v0::nil => eval_static_extfz stop start v0 | (Oextfs stop start), v0::nil => eval_static_extfs stop start v0 | (Oextfzl stop start), v0::nil => eval_static_extfzl stop start v0 | (Oextfsl stop start), v0::nil => eval_static_extfsl stop start v0 | (Oinsf stop start), v0::v1::nil => eval_static_insf stop start v0 v1 | (Oinsfl stop start), v0::v1::nil => eval_static_insfl stop start v0 v1 + | Osel c ty, v1::v2::vc::nil => select (eval_static_condition0 c vc) v1 v2 + | Oselimm c imm, v1::vc::nil => select (eval_static_condition0 c vc) v1 (I imm) + | Osellimm c imm, v1::vc::nil => select (eval_static_condition0 c vc) v1 (L imm) | _, _ => Vbot end. @@ -291,6 +317,99 @@ Hypothesis GENV: genv_match bc ge. Variable sp: block. Hypothesis STACK: bc sp = BCstack. +Lemma minf_sound: + forall v x w y, vmatch bc v x -> vmatch bc w y -> vmatch bc (ExtValues.minf v w) (minf x y). +Proof. + apply (binop_float_sound bc ExtFloat.min); assumption. +Qed. + +Lemma maxf_sound: + forall v x w y, vmatch bc v x -> vmatch bc w y -> vmatch bc (ExtValues.maxf v w) (maxf x y). +Proof. + apply (binop_float_sound bc ExtFloat.max); assumption. +Qed. + +Lemma minfs_sound: + forall v x w y, vmatch bc v x -> vmatch bc w y -> vmatch bc (ExtValues.minfs v w) (minfs x y). +Proof. + apply (binop_single_sound bc ExtFloat32.min); assumption. +Qed. + +Lemma maxfs_sound: + forall v x w y, vmatch bc v x -> vmatch bc w y -> vmatch bc (ExtValues.maxfs v w) (maxfs x y). +Proof. + apply (binop_single_sound bc ExtFloat32.max); assumption. +Qed. + +Lemma invfs_sound: + forall v x, vmatch bc v x -> vmatch bc (ExtValues.invfs v) (invfs x). +Proof. + intros v x; + intro MATCH; + inversion MATCH; + simpl; + constructor. +Qed. + +Lemma triple_op_float_sound: + forall f a x b y c z, + vmatch bc a x -> vmatch bc b y -> vmatch bc c z -> + vmatch bc (ExtValues.triple_op_float f a b c) + (triple_op_float f x y z). +Proof. + intros until z. + intros Hax Hby Hcz. + inv Hax; simpl; try constructor; + inv Hby; simpl; try constructor; + inv Hcz; simpl; try constructor. +Qed. + +Lemma triple_op_single_sound: + forall f a x b y c z, + vmatch bc a x -> vmatch bc b y -> vmatch bc c z -> + vmatch bc (ExtValues.triple_op_single f a b c) + (triple_op_single f x y z). +Proof. + intros until z. + intros Hax Hby Hcz. + inv Hax; simpl; try constructor; + inv Hby; simpl; try constructor; + inv Hcz; simpl; try constructor. +Qed. + +Lemma fmaddf_sound : + forall a x b y c z, vmatch bc a x -> vmatch bc b y -> vmatch bc c z -> + vmatch bc (ExtValues.fmaddf a b c) (fmaddf x y z). +Proof. + intros. unfold ExtValues.fmaddf, fmaddf. + apply triple_op_float_sound; assumption. +Qed. + +Lemma fmaddfs_sound : + forall a x b y c z, vmatch bc a x -> vmatch bc b y -> vmatch bc c z -> + vmatch bc (ExtValues.fmaddfs a b c) (fmaddfs x y z). +Proof. + intros. unfold ExtValues.fmaddfs, fmaddfs. + apply triple_op_single_sound; assumption. +Qed. + +Lemma fmsubf_sound : + forall a x b y c z, vmatch bc a x -> vmatch bc b y -> vmatch bc c z -> + vmatch bc (ExtValues.fmsubf a b c) (fmsubf x y z). +Proof. + intros. unfold ExtValues.fmsubf, fmsubf. + apply triple_op_float_sound; assumption. +Qed. + +Lemma fmsubfs_sound : + forall a x b y c z, vmatch bc a x -> vmatch bc b y -> vmatch bc c z -> + vmatch bc (ExtValues.fmsubfs a b c) (fmsubfs x y z). +Proof. + intros. unfold ExtValues.fmsubfs, fmsubfs. + apply triple_op_single_sound; assumption. +Qed. +Hint Resolve minf_sound maxf_sound minfs_sound maxfs_sound invfs_sound fmaddf_sound fmaddfs_sound fmsubf_sound fmsubfs_sound : va. + Theorem eval_static_condition_sound: forall cond vargs m aargs, list_forall2 (vmatch bc) vargs aargs -> @@ -353,58 +472,70 @@ Proof. rewrite Ptrofs.add_zero_l; eauto with va. Qed. +Theorem eval_static_addressing_sound_none: + forall addr vargs aargs, + eval_addressing ge (Vptr sp Ptrofs.zero) addr vargs = None -> + list_forall2 (vmatch bc) vargs aargs -> + (eval_static_addressing addr aargs) = Vbot. +Proof. + unfold eval_addressing, eval_static_addressing. + intros until aargs. intros Heval_none Hlist. + inv Hlist. + destruct addr; trivial; discriminate. + inv H0. + destruct addr; trivial; discriminate. + inv H2. + destruct addr; trivial; discriminate. + inv H3; + destruct addr; trivial; discriminate. +Qed. + Theorem eval_static_operation_sound: forall op vargs m vres aargs, eval_operation ge (Vptr sp Ptrofs.zero) op vargs m = Some vres -> list_forall2 (vmatch bc) vargs aargs -> vmatch bc vres (eval_static_operation op aargs). Proof. - unfold eval_operation, eval_static_operation, eval_static_select, eval_static_selectl, eval_static_selectf, eval_static_selectfs; intros; + unfold eval_operation, eval_static_operation, addx, revsubx, addxl, revsubxl; intros. destruct op; InvHyps; eauto with va. - destruct (propagate_float_constants tt); constructor. - destruct (propagate_float_constants tt); constructor. - rewrite Ptrofs.add_zero_l; eauto with va. - apply of_optbool_sound. eapply eval_static_condition_sound; eauto. - (* select *) - - assert (Hcond : (cmatch (eval_condition0 cond a2 m) (eval_static_condition0 cond b2))) by (apply eval_static_condition0_sound; assumption). - rewrite eval_select_to2. - unfold eval_select2. - inv Hcond; trivial; try constructor. - + apply binop_int_sound; assumption. - + destruct a1; destruct a0; try apply vmatch_ifptr_undef. - apply vmatch_ifptr_i. - + destruct (eval_condition0 cond a2 m); destruct a1; destruct a0; try apply vmatch_ifptr_undef. - apply vmatch_ifptr_i. - (* selectl *) - - assert (Hcond : (cmatch (eval_condition0 cond a2 m) (eval_static_condition0 cond b2))) by (apply eval_static_condition0_sound; assumption). - rewrite eval_selectl_to2. - unfold eval_selectl2. - inv Hcond; trivial; try constructor. - + apply binop_long_sound; assumption. - + destruct a1; destruct a0; try apply vmatch_ifptr_undef. - apply vmatch_ifptr_l. - + destruct (eval_condition0 cond a2 m); destruct a1; destruct a0; try apply vmatch_ifptr_undef. - apply vmatch_ifptr_l. - (* selectf *) - - assert (Hcond : (cmatch (eval_condition0 cond a2 m) (eval_static_condition0 cond b2))) by (apply eval_static_condition0_sound; assumption). - rewrite eval_selectf_to2. - unfold eval_selectf2. - inv Hcond; trivial; try constructor. - + apply binop_float_sound; assumption. - + destruct a1; destruct a0; try apply vmatch_ifptr_undef. - constructor. - + destruct (eval_condition0 cond a2 m); destruct a1; destruct a0; try apply vmatch_ifptr_undef. - constructor. - (* selectfs *) - - assert (Hcond : (cmatch (eval_condition0 cond a2 m) (eval_static_condition0 cond b2))) by (apply eval_static_condition0_sound; assumption). - rewrite eval_selectfs_to2. - unfold eval_selectfs2. - inv Hcond; trivial; try constructor. - + apply binop_single_sound; assumption. - + destruct a1; destruct a0; try apply vmatch_ifptr_undef. - constructor. - + destruct (eval_condition0 cond a2 m); destruct a1; destruct a0; try apply vmatch_ifptr_undef. - constructor. + - destruct (propagate_float_constants tt); constructor. + - destruct (propagate_float_constants tt); constructor. + - rewrite Ptrofs.add_zero_l; eauto with va. + - replace(match Val.shl a1 (Vint (int_of_shift1_4 shift)) with + | Vint n2 => Vint (Int.add n n2) + | Vptr b2 ofs2 => + if Archi.ptr64 + then Vundef + else Vptr b2 (Ptrofs.add ofs2 (Ptrofs.of_int n)) + | _ => Vundef + end) with (Val.add (Vint n) (Val.shl a1 (Vint (int_of_shift1_4 shift)))). + + eauto with va. + + destruct a1; destruct shift; reflexivity. + - (*revsubimm*) inv H1; constructor. + - replace (match Val.shl a1 (Vint (int_of_shift1_4 shift)) with + | Vint n2 => Vint (Int.sub n n2) + | _ => Vundef + end) with (Val.sub (Vint n) (Val.shl a1 (Vint (int_of_shift1_4 shift)))). + + eauto with va. + + destruct n; destruct shift; reflexivity. + - replace (match Val.shll a1 (Vint (int_of_shift1_4 shift)) with + | Vlong n2 => Vlong (Int64.add n n2) + | Vptr b2 ofs2 => + if Archi.ptr64 + then Vptr b2 (Ptrofs.add ofs2 (Ptrofs.of_int64 n)) + else Vundef + | _ => Vundef + end) with (Val.addl (Vlong n) (Val.shll a1 (Vint (int_of_shift1_4 shift)))). + + eauto with va. + + destruct a1; destruct shift; reflexivity. + - inv H1; constructor. + - replace (match Val.shll a1 (Vint (int_of_shift1_4 shift)) with + | Vlong n2 => Vlong (Int64.sub n n2) + | _ => Vundef + end) with (Val.subl (Vlong n) (Val.shll a1 (Vint (int_of_shift1_4 shift)))). + + eauto with va. + + destruct a1; destruct shift; reflexivity. + - apply of_optbool_sound. eapply eval_static_condition_sound; eauto. (* extfz *) - unfold extfz, eval_static_extfz. @@ -440,6 +571,12 @@ Proof. destruct (is_bitfieldl _ _). + inv H1; inv H0; simpl; try constructor; destruct (Int.ltu _ _); simpl; constructor. + constructor. + (* select *) + - apply select_sound; auto. eapply eval_static_condition0_sound; eauto. + (* select imm *) + - apply select_sound; auto with va. eapply eval_static_condition0_sound; eauto. + (* select long imm *) + - apply select_sound; auto with va. eapply eval_static_condition0_sound; eauto. Qed. End SOUNDNESS. diff --git a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v index 618f3ebe..cf46072f 100644 --- a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v +++ b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v @@ -1,6 +1,7 @@ (** Syntax and Sequential Semantics of Abstract Basic Blocks. *) - +Require Import Setoid. +Require Import ImpPrelude. Module Type PseudoRegisters. @@ -24,16 +25,8 @@ Parameter op: Type. (* type of operations *) Parameter genv: Type. (* environment to be used for evaluating an op *) -(* NB: possible generalization - - relation after/before. -*) Parameter op_eval: genv -> op -> list value -> option value. -Parameter is_constant: op -> bool. - -Parameter is_constant_correct: - forall ge o, is_constant o = true -> op_eval ge o nil <> None. - End LangParam. @@ -54,6 +47,9 @@ Definition mem := R.t -> value. Definition assign (m: mem) (x:R.t) (v: value): mem := fun y => if R.eq_dec x y then v else m y. + +(** expressions *) + Inductive exp := | PReg (x:R.t) | Op (o:op) (le: list_exp) @@ -140,7 +136,7 @@ Proof. Qed. -(** A small theory of bblock equality *) +(** A small theory of bblock simulation *) (* equalities on bblock outputs *) Definition res_eq (om1 om2: option mem): Prop := @@ -240,6 +236,195 @@ Qed. End SEQLANG. +Module Terms. + +(** terms in the symbolic evaluation +NB: such a term represents the successive computations in one given pseudo-register +*) + +Inductive term := + | Input (x:R.t) (hid:hashcode) + | App (o: op) (l: list_term) (hid:hashcode) +with list_term := + | LTnil (hid:hashcode) + | LTcons (t:term) (l:list_term) (hid:hashcode) + . + +Scheme term_mut := Induction for term Sort Prop +with list_term_mut := Induction for list_term Sort Prop. + +Bind Scope pattern_scope with term. +Delimit Scope term_scope with term. +Delimit Scope pattern_scope with pattern. + +Notation "[ ]" := (LTnil _) (format "[ ]"): pattern_scope. +Notation "[ x ]" := (LTcons x [] _): pattern_scope. +Notation "[ x ; y ; .. ; z ]" := (LTcons x (LTcons y .. (LTcons z (LTnil _) _) .. _) _): pattern_scope. +Notation "o @ l" := (App o l _) (at level 50, no associativity): pattern_scope. + +Import HConsingDefs. + +Notation "[ ]" := (LTnil unknown_hid) (format "[ ]"): term_scope. +Notation "[ x ]" := (LTcons x [] unknown_hid): term_scope. +Notation "[ x ; y ; .. ; z ]" := (LTcons x (LTcons y .. (LTcons z (LTnil unknown_hid) unknown_hid) .. unknown_hid) unknown_hid): term_scope. +Notation "o @ l" := (App o l unknown_hid) (at level 50, no associativity): term_scope. + +Local Open Scope pattern_scope. + +Fixpoint term_eval (ge: genv) (t: term) (m: mem): option value := + match t with + | Input x _ => Some (m x) + | o @ l => + match list_term_eval ge l m with + | Some v => op_eval ge o v + | _ => None + end + end +with list_term_eval ge (l: list_term) (m: mem) {struct l}: option (list value) := + match l with + | [] => Some nil + | LTcons t l' _ => + match term_eval ge t m, list_term_eval ge l' m with + | Some v, Some lv => Some (v::lv) + | _, _ => None + end + end. + + +Definition term_get_hid (t: term): hashcode := + match t with + | Input _ hid => hid + | App _ _ hid => hid + end. + +Definition list_term_get_hid (l: list_term): hashcode := + match l with + | LTnil hid => hid + | LTcons _ _ hid => hid + end. + + +Fixpoint allvalid ge (l: list term) m : Prop := + match l with + | nil => True + | t::nil => term_eval ge t m <> None + | t::l' => term_eval ge t m <> None /\ allvalid ge l' m + end. + +Lemma allvalid_extensionality ge (l: list term) m: + allvalid ge l m <-> (forall t, List.In t l -> term_eval ge t m <> None). +Proof. + induction l as [|t l]; simpl; try (tauto). + destruct l. + - intuition (congruence || eauto). + - rewrite IHl; clear IHl. intuition (congruence || eauto). +Qed. + +Record pseudo_term: Type := intro_fail { + mayfail: list term; + effect: term +}. + +Lemma inf_option_equivalence (A:Type) (o1 o2: option A): + (o1 <> None -> o1 = o2) <-> (forall m1, o1 = Some m1 -> o2 = Some m1). +Proof. + destruct o1; intuition (congruence || eauto). + symmetry; eauto. +Qed. + +Definition match_pt (t: term) (pt: pseudo_term) := + (forall ge m, term_eval ge t m <> None <-> allvalid ge pt.(mayfail) m) + /\ (forall ge m0 m1, term_eval ge t m0 = Some m1 -> term_eval ge pt.(effect) m0 = Some m1). + +Lemma intro_fail_correct (l: list term) (t: term) : + (forall ge m, term_eval ge t m <> None <-> allvalid ge l m) -> match_pt t (intro_fail l t). +Proof. + unfold match_pt; simpl; intros; intuition congruence. +Qed. +Hint Resolve intro_fail_correct: wlp. + +Definition identity_fail (t: term):= intro_fail [t] t. + +Lemma identity_fail_correct (t: term): match_pt t (identity_fail t). +Proof. + eapply intro_fail_correct; simpl; tauto. +Qed. +Global Opaque identity_fail. +Hint Resolve identity_fail_correct: wlp. + +Definition nofail (is_constant: op -> bool) (t: term):= + match t with + | Input x _ => intro_fail ([])%list t + | o @ [] => if is_constant o then (intro_fail ([])%list t) else (identity_fail t) + | _ => identity_fail t + end. + +Lemma nofail_correct (is_constant: op -> bool) t: + (forall ge o, is_constant o = true -> op_eval ge o nil <> None) -> match_pt t (nofail is_constant t). +Proof. + destruct t; simpl. + + intros; eapply intro_fail_correct; simpl; intuition congruence. + + intros; destruct l; simpl; auto with wlp. + destruct (is_constant o) eqn:Heqo; simpl; intuition eauto with wlp. + eapply intro_fail_correct; simpl; intuition eauto with wlp. +Qed. +Global Opaque nofail. +Hint Resolve nofail_correct: wlp. + +Definition term_equiv t1 t2:= forall ge m, term_eval ge t1 m = term_eval ge t2 m. + +Global Instance term_equiv_Equivalence : Equivalence term_equiv. +Proof. + split; intro x; unfold term_equiv; intros; eauto. + eapply eq_trans; eauto. +Qed. + +Lemma match_pt_term_equiv t1 t2 pt: term_equiv t1 t2 -> match_pt t1 pt -> match_pt t2 pt. +Proof. + unfold match_pt, term_equiv. + intros H. intuition; try (erewrite <- H1 in * |- *; congruence). + erewrite <- H2; eauto; congruence. +Qed. +Hint Resolve match_pt_term_equiv: wlp. + +Definition app_fail (l: list term) (pt: pseudo_term): pseudo_term := + {| mayfail := List.rev_append l pt.(mayfail); effect := pt.(effect) |}. + +Lemma app_fail_allvalid_correct l pt t1 t2: forall + (V1: forall (ge : genv) (m : mem), term_eval ge t1 m <> None <-> allvalid ge (mayfail pt) m) + (V2: forall (ge : genv) (m : mem), term_eval ge t2 m <> None <-> allvalid ge (mayfail {| mayfail := t1 :: l; effect := t1 |}) m) + (ge : genv) (m : mem), term_eval ge t2 m <> None <-> allvalid ge (mayfail (app_fail l pt)) m. +Proof. + intros; generalize (V1 ge m) (V2 ge m); rewrite !allvalid_extensionality; simpl. clear V1 V2. + intuition subst. + + rewrite rev_append_rev, in_app_iff, <- in_rev in H3. destruct H3; eauto. + + eapply H3; eauto. + intros. intuition subst. + * eapply H2; eauto. intros; eapply H0; eauto. rewrite rev_append_rev, in_app_iff; auto. + * intros; eapply H0; eauto. rewrite rev_append_rev, in_app_iff, <- in_rev; auto. +Qed. +Local Hint Resolve app_fail_allvalid_correct: core. + +Lemma app_fail_correct l pt t1 t2: + match_pt t1 pt -> + match_pt t2 {| mayfail:=t1::l; effect:=t1 |} -> + match_pt t2 (app_fail l pt). +Proof. + unfold match_pt in * |- *; intros (V1 & E1) (V2 & E2); split; intros ge m; try (eauto; fail). +Qed. +Extraction Inline app_fail. + +Import ImpCore.Notations. +Local Open Scope impure_scope. + +Record reduction:= { + result:> term -> ?? pseudo_term; + result_correct: forall t, WHEN result t ~> pt THEN match_pt t pt; +}. +Hint Resolve result_correct: wlp. + +End Terms. + End MkSeqLanguage. diff --git a/mppa_k1c/abstractbb/DepTreeTheory.v b/mppa_k1c/abstractbb/DepTreeTheory.v deleted file mode 100644 index c7bed8bf..00000000 --- a/mppa_k1c/abstractbb/DepTreeTheory.v +++ /dev/null @@ -1,456 +0,0 @@ -(** Dependency Trees of Abstract Basic Blocks - -with a purely-functional-but-exponential test. - -*) - - -Require Setoid. (* in order to rewrite <-> *) -Require Export AbstractBasicBlocksDef. -Require Import List. - -Module Type PseudoRegDictionary. - -Declare Module R: PseudoRegisters. - -Parameter t: Type -> Type. - -Parameter get: forall {A}, t A -> R.t -> option A. - -Parameter set: forall {A}, t A -> R.t -> A -> t A. - -Parameter set_spec_eq: forall A d x (v: A), - get (set d x v) x = Some v. - -Parameter set_spec_diff: forall A d x y (v: A), - x <> y -> get (set d x v) y = get d y. - -Parameter empty: forall {A}, t A. - -Parameter empty_spec: forall A x, - get (empty (A:=A)) x = None. - -End PseudoRegDictionary. - - -(** * Computations of "bblock" Dependencies and application to the equality test *) - -Module DepTree (L: SeqLanguage) (Dict: PseudoRegDictionary with Module R:=L.LP.R). - -Export L. -Export LP. - -Section DEPTREE. - -(** Dependency Trees of these "bblocks" - -NB: each tree represents the successive computations in one given resource - -*) - -Inductive tree := - | Tname (x:R.t) - | Top (o: op) (l: list_tree) -with list_tree := - | Tnil: list_tree - | Tcons (t:tree) (l:list_tree): list_tree - . - - -Fixpoint tree_eval (ge: genv) (t: tree) (m: mem): option value := - match t with - | Tname x => Some (m x) - | Top o l => - match list_tree_eval ge l m with - | Some v => op_eval ge o v - | _ => None - end - end -with list_tree_eval ge (l: list_tree) (m: mem) {struct l}: option (list value) := - match l with - | Tnil => Some nil - | Tcons t l' => - match (tree_eval ge t m), (list_tree_eval ge l' m) with - | Some v, Some lv => Some (v::lv) - | _, _ => None - end - end. - -Definition deps_get (d:Dict.t tree) x := - match Dict.get d x with - | None => Tname x - | Some t => t - end. - -Fixpoint exp_tree (e: exp) d old: tree := - match e with - | PReg x => deps_get d x - | Op o le => Top o (list_exp_tree le d old) - | Old e => exp_tree e old old - end -with list_exp_tree (le: list_exp) d old: list_tree := - match le with - | Enil => Tnil - | Econs e le' => Tcons (exp_tree e d old) (list_exp_tree le' d old) - | LOld le => list_exp_tree le old old - end. - -Record deps:= {pre: genv -> mem -> Prop; post: Dict.t tree}. - -Coercion post: deps >-> Dict.t. - -Definition deps_eval ge (d: deps) x (m:mem) := - tree_eval ge (deps_get d x) m. - -Definition deps_set (d:deps) x (t:tree) := - {| pre:=(fun ge m => (deps_eval ge d x m) <> None /\ (d.(pre) ge m)); - post:=Dict.set d x t |}. - -Definition deps_empty := {| pre:=fun _ _ => True; post:=Dict.empty |}. - -Variable ge: genv. - -Lemma set_spec_eq d x t m: - deps_eval ge (deps_set d x t) x m = tree_eval ge t m. -Proof. - unfold deps_eval, deps_set, deps_get; simpl; rewrite Dict.set_spec_eq; simpl; auto. -Qed. - -Lemma set_spec_diff d x y t m: - x <> y -> deps_eval ge (deps_set d x t) y m = deps_eval ge d y m. -Proof. - intros; unfold deps_eval, deps_set, deps_get; simpl; rewrite Dict.set_spec_diff; simpl; auto. -Qed. - -Lemma deps_eval_empty x m: deps_eval ge deps_empty x m = Some (m x). -Proof. - unfold deps_eval, deps_get; rewrite Dict.empty_spec; simpl; auto. -Qed. - -Hint Rewrite set_spec_eq deps_eval_empty: dict_rw. - -Fixpoint inst_deps (i: inst) (d old: deps): deps := - match i with - | nil => d - | (x, e)::i' => - let t:=exp_tree e d old in - inst_deps i' (deps_set d x t) old - end. - -Fixpoint bblock_deps_rec (p: bblock) (d: deps): deps := - match p with - | nil => d - | i::p' => - let d':=inst_deps i d d in - bblock_deps_rec p' d' - end. - -Local Hint Resolve deps_eval_empty. - -Definition bblock_deps: bblock -> deps - := fun p => bblock_deps_rec p deps_empty. - -Lemma inst_deps_pre_monotonic i old: forall d m, - (pre (inst_deps i d old) ge m) -> (pre d ge m). -Proof. - induction i as [|[y e] i IHi]; simpl; auto. - intros d a H; generalize (IHi _ _ H); clear H IHi. - unfold deps_set; simpl; intuition. -Qed. - -Lemma bblock_deps_pre_monotonic p: forall d m, - (pre (bblock_deps_rec p d) ge m) -> (pre d ge m). -Proof. - induction p as [|i p' IHp']; simpl; eauto. - intros d a H; eapply inst_deps_pre_monotonic; eauto. -Qed. - -Local Hint Resolve inst_deps_pre_monotonic bblock_deps_pre_monotonic. - -Lemma tree_eval_exp e od m0 old: - (forall x, deps_eval ge od x m0 = Some (old x)) -> - forall d m1, - (forall x, deps_eval ge d x m0 = Some (m1 x)) -> - tree_eval ge (exp_tree e d od) m0 = exp_eval ge e m1 old. -Proof. - unfold deps_eval in * |- *; intro H. - induction e using exp_mut with - (P0:=fun l => forall (d:deps) m1, (forall x, tree_eval ge (deps_get d x) m0 = Some (m1 x)) -> list_tree_eval ge (list_exp_tree l d od) m0 = list_exp_eval ge l m1 old); - simpl; auto. - - intros; erewrite IHe; eauto. - - intros. erewrite IHe, IHe0; eauto. -Qed. - -Lemma inst_deps_abort i m0 x old: forall d, - pre (inst_deps i d old) ge m0 -> - deps_eval ge d x m0 = None -> - deps_eval ge (inst_deps i d old) x m0 = None. -Proof. - induction i as [|[y e] i IHi]; simpl; auto. - intros d VALID H; erewrite IHi; eauto. clear IHi. - destruct (R.eq_dec x y). - * subst; autorewrite with dict_rw. - generalize (inst_deps_pre_monotonic _ _ _ _ VALID); clear VALID. - unfold deps_set; simpl; intuition congruence. - * rewrite set_spec_diff; auto. -Qed. - -Lemma block_deps_rec_abort p m0 x: forall d, - pre (bblock_deps_rec p d) ge m0 -> - deps_eval ge d x m0 = None -> - deps_eval ge (bblock_deps_rec p d) x m0 = None. -Proof. - induction p; simpl; auto. - intros d VALID H; erewrite IHp; eauto. clear IHp. - eapply inst_deps_abort; eauto. -Qed. - -Lemma inst_deps_Some_correct1 i m0 old od: - (forall x, deps_eval ge od x m0 = Some (old x)) -> - forall (m1 m2: mem) (d: deps), - inst_run ge i m1 old = Some m2 -> - (forall x, deps_eval ge d x m0 = Some (m1 x)) -> - forall x, deps_eval ge (inst_deps i d od) x m0 = Some (m2 x). -Proof. - intro X; induction i as [|[x e] i IHi]; simpl; intros m1 m2 d H. - - inversion_clear H; eauto. - - intros H0 x0. - destruct (exp_eval ge e m1 old) eqn:Heqov; try congruence. - refine (IHi _ _ _ _ _ _); eauto. - clear x0; intros x0. - unfold assign; destruct (R.eq_dec x x0). - * subst; autorewrite with dict_rw. - erewrite tree_eval_exp; eauto. - * rewrite set_spec_diff; auto. -Qed. - -Lemma bblocks_deps_rec_Some_correct1 p m0: forall (m1 m2: mem) d, - run ge p m1 = Some m2 -> - (forall x, deps_eval ge d x m0 = Some (m1 x)) -> - forall x, deps_eval ge (bblock_deps_rec p d) x m0 = Some (m2 x). -Proof. - Local Hint Resolve inst_deps_Some_correct1. - induction p as [ | i p]; simpl; intros m1 m2 d H. - - inversion_clear H; eauto. - - intros H0 x0. - destruct (inst_run ge i m1 m1) eqn: Heqov. - + refine (IHp _ _ _ _ _ _); eauto. - + inversion H. -Qed. - -Lemma bblock_deps_Some_correct1 p m0 m1: - run ge p m0 = Some m1 - -> forall x, deps_eval ge (bblock_deps p) x m0 = Some (m1 x). -Proof. - intros; eapply bblocks_deps_rec_Some_correct1; eauto. -Qed. - -Lemma inst_deps_None_correct i m0 old od: - (forall x, deps_eval ge od x m0 = Some (old x)) -> - forall m1 d, pre (inst_deps i d od) ge m0 -> - (forall x, deps_eval ge d x m0 = Some (m1 x)) -> - inst_run ge i m1 old = None -> exists x, deps_eval ge (inst_deps i d od) x m0 = None. -Proof. - intro X; induction i as [|[x e] i IHi]; simpl; intros m1 d. - - discriminate. - - intros VALID H0. - destruct (exp_eval ge e m1 old) eqn: Heqov. - + refine (IHi _ _ _ _); eauto. - intros x0; unfold assign; destruct (R.eq_dec x x0). - * subst; autorewrite with dict_rw. - erewrite tree_eval_exp; eauto. - * rewrite set_spec_diff; auto. - + intuition. - constructor 1 with (x:=x); simpl. - apply inst_deps_abort; auto. - autorewrite with dict_rw. - erewrite tree_eval_exp; eauto. -Qed. - -Lemma inst_deps_Some_correct2 i m0 old od: - (forall x, deps_eval ge od x m0 = Some (old x)) -> - forall (m1 m2: mem) d, - pre (inst_deps i d od) ge m0 -> - (forall x, deps_eval ge d x m0 = Some (m1 x)) -> - (forall x, deps_eval ge (inst_deps i d od) x m0 = Some (m2 x)) -> - res_eq (Some m2) (inst_run ge i m1 old). -Proof. - intro X. - induction i as [|[x e] i IHi]; simpl; intros m1 m2 d VALID H0. - - intros H; eapply ex_intro; intuition eauto. - generalize (H0 x); rewrite H. - congruence. - - intros H. - destruct (exp_eval ge e m1 old) eqn: Heqov. - + refine (IHi _ _ _ _ _ _); eauto. - intros x0; unfold assign; destruct (R.eq_dec x x0). - * subst. autorewrite with dict_rw. - erewrite tree_eval_exp; eauto. - * rewrite set_spec_diff; auto. - + generalize (H x). - rewrite inst_deps_abort; discriminate || auto. - autorewrite with dict_rw. - erewrite tree_eval_exp; eauto. -Qed. - -Lemma bblocks_deps_rec_Some_correct2 p m0: forall (m1 m2: mem) d, - pre (bblock_deps_rec p d) ge m0 -> - (forall x, deps_eval ge d x m0 = Some (m1 x)) -> - (forall x, deps_eval ge (bblock_deps_rec p d) x m0 = Some (m2 x)) -> - res_eq (Some m2) (run ge p m1). -Proof. - induction p as [|i p]; simpl; intros m1 m2 d VALID H0. - - intros H; eapply ex_intro; intuition eauto. - generalize (H0 x); rewrite H. - congruence. - - intros H. - destruct (inst_run ge i m1 m1) eqn: Heqom. - + refine (IHp _ _ _ _ _ _); eauto. - + assert (X: exists x, tree_eval ge (deps_get (inst_deps i d d) x) m0 = None). - { eapply inst_deps_None_correct; eauto. } - destruct X as [x H1]. - generalize (H x). - erewrite block_deps_rec_abort; eauto. - congruence. -Qed. - - -Lemma bblock_deps_Some_correct2 p m0 m1: - pre (bblock_deps p) ge m0 -> - (forall x, deps_eval ge (bblock_deps p) x m0 = Some (m1 x)) - -> res_eq (Some m1) (run ge p m0). -Proof. - intros; eapply bblocks_deps_rec_Some_correct2; eauto. -Qed. - -Lemma inst_valid i m0 old od: - (forall x, deps_eval ge od x m0 = Some (old x)) -> - forall (m1 m2: mem) (d: deps), - pre d ge m0 -> - inst_run ge i m1 old = Some m2 -> - (forall x, deps_eval ge d x m0 = Some (m1 x)) -> - pre (inst_deps i d od) ge m0. -Proof. - induction i as [|[x e] i IHi]; simpl; auto. - intros Hold m1 m2 d VALID0 H Hm1. - destruct (exp_eval ge e m1 old) eqn: Heq; simpl; try congruence. - eapply IHi; eauto. - + unfold deps_set in * |- *; simpl. - rewrite Hm1; intuition congruence. - + intros x0. unfold assign; destruct (R.eq_dec x x0). - * subst; autorewrite with dict_rw. - erewrite tree_eval_exp; eauto. - * rewrite set_spec_diff; auto. -Qed. - - -Lemma block_deps_rec_valid p m0: forall (m1 m2: mem) (d:deps), - pre d ge m0 -> - run ge p m1 = Some m2 -> - (forall x, deps_eval ge d x m0 = Some (m1 x)) -> - pre (bblock_deps_rec p d) ge m0. -Proof. - Local Hint Resolve inst_valid. - induction p as [ | i p]; simpl; intros m1 d H; auto. - intros H0 H1. - destruct (inst_run ge i m1 m1) eqn: Heqov; eauto. - congruence. -Qed. - -Lemma bblock_deps_valid p m0 m1: - run ge p m0 = Some m1 -> - pre (bblock_deps p) ge m0. -Proof. - intros; eapply block_deps_rec_valid; eauto. - unfold deps_empty; simpl. auto. -Qed. - -Definition valid ge d m := pre d ge m /\ forall x, deps_eval ge d x m <> None. - -Theorem bblock_deps_simu p1 p2: - (forall m, valid ge (bblock_deps p1) m -> valid ge (bblock_deps p2) m) -> - (forall m0 x m1, valid ge (bblock_deps p1) m0 -> deps_eval ge (bblock_deps p1) x m0 = Some m1 -> - deps_eval ge (bblock_deps p2) x m0 = Some m1) -> - bblock_simu ge p1 p2. -Proof. - Local Hint Resolve bblock_deps_valid bblock_deps_Some_correct1. - unfold valid; intros INCL EQUIV m DONTFAIL. - destruct (run ge p1 m) as [m1|] eqn: RUN1; simpl; try congruence. - assert (X: forall x, deps_eval ge (bblock_deps p1) x m = Some (m1 x)); eauto. - eapply bblock_deps_Some_correct2; eauto. - + destruct (INCL m); intuition eauto. - congruence. - + intro x; apply EQUIV; intuition eauto. - congruence. -Qed. - -Lemma valid_set_decompose_1 d t x m: - valid ge (deps_set d x t) m -> valid ge d m. -Proof. - unfold valid; intros ((PRE1 & PRE2) & VALID); split. - + intuition. - + intros x0 H. case (R.eq_dec x x0). - * intuition congruence. - * intros DIFF; eapply VALID. erewrite set_spec_diff; eauto. -Qed. - -Lemma valid_set_decompose_2 d t x m: - valid ge (deps_set d x t) m -> tree_eval ge t m <> None. -Proof. - unfold valid; intros ((PRE1 & PRE2) & VALID) H. - generalize (VALID x); autorewrite with dict_rw. - tauto. -Qed. - -Lemma valid_set_proof d x t m: - valid ge d m -> tree_eval ge t m <> None -> valid ge (deps_set d x t) m. -Proof. - unfold valid; intros (PRE & VALID) PREt. split. - + split; auto. - + intros x0; case (R.eq_dec x x0). - - intros; subst; autorewrite with dict_rw. auto. - - intros. rewrite set_spec_diff; auto. -Qed. - -End DEPTREE. - -End DepTree. - -Require Import PArith. -Require Import FMapPositive. - -Module PosDict <: PseudoRegDictionary with Module R:=Pos. - -Module R:=Pos. - -Definition t:=PositiveMap.t. - -Definition get {A} (d:t A) (x:R.t): option A - := PositiveMap.find x d. - -Definition set {A} (d:t A) (x:R.t) (v:A): t A - := PositiveMap.add x v d. - -Local Hint Unfold PositiveMap.E.eq. - -Lemma set_spec_eq A d x (v: A): - get (set d x v) x = Some v. -Proof. - unfold get, set; apply PositiveMap.add_1; auto. -Qed. - -Lemma set_spec_diff A d x y (v: A): - x <> y -> get (set d x v) y = get d y. -Proof. - unfold get, set; intros; apply PositiveMap.gso; auto. -Qed. - -Definition empty {A}: t A := PositiveMap.empty A. - -Lemma empty_spec A x: - get (empty (A:=A)) x = None. -Proof. - unfold get, empty; apply PositiveMap.gempty; auto. -Qed. - -End PosDict.
\ No newline at end of file diff --git a/mppa_k1c/abstractbb/ImpDep.v b/mppa_k1c/abstractbb/ImpDep.v deleted file mode 100644 index eebf396d..00000000 --- a/mppa_k1c/abstractbb/ImpDep.v +++ /dev/null @@ -1,960 +0,0 @@ -(** Dependency Graph of Abstract Basic Blocks - -using imperative hash-consing technique in order to get a linear equivalence test. - -*) - -Require Export Impure.ImpHCons. -Export Notations. - -Require Export DepTreeTheory. - -Require Import PArith. - - -Local Open Scope impure. - -Import ListNotations. -Local Open Scope list_scope. - - -Module Type ImpParam. - -Include LangParam. - -Parameter op_eq: op -> op -> ?? bool. - -Parameter op_eq_correct: forall o1 o2, - WHEN op_eq o1 o2 ~> b THEN - b=true -> o1 = o2. - -End ImpParam. - - -Module Type ISeqLanguage. - -Declare Module LP: ImpParam. - -Include MkSeqLanguage LP. - -End ISeqLanguage. - - -Module Type ImpDict. - -Include PseudoRegDictionary. - -Parameter eq_test: forall {A}, t A -> t A -> ?? bool. - -Parameter eq_test_correct: forall A (d1 d2: t A), - WHEN eq_test d1 d2 ~> b THEN - b=true -> forall x, get d1 x = get d2 x. - -(* NB: we could also take an eq_test on R.t (but not really useful with "pure" dictionaries *) - - -(* only for debugging *) -Parameter not_eq_witness: forall {A}, t A -> t A -> ?? option R.t. - -End ImpDict. - -Module ImpDepTree (L: ISeqLanguage) (Dict: ImpDict with Module R:=L.LP.R). - -Module DT := DepTree L Dict. - -Import DT. - -Section CanonBuilding. - -Variable hC_tree: pre_hashV tree -> ?? hashV tree. -Hypothesis hC_tree_correct: forall t, WHEN hC_tree t ~> t' THEN pre_data t=data t'. - -Variable hC_list_tree: pre_hashV list_tree -> ?? hashV list_tree. -Hypothesis hC_list_tree_correct: forall t, WHEN hC_list_tree t ~> t' THEN pre_data t=data t'. - -(* First, we wrap constructors for hashed values !*) - -Local Open Scope positive. -Local Open Scope list_scope. - -Definition hTname (x:R.t) (debug: option pstring): ?? hashV tree := - DO hc <~ hash 1;; - DO hv <~ hash x;; - hC_tree {| pre_data:=Tname x; hcodes :=[hc;hv]; debug_info := debug |}. - -Lemma hTname_correct x dbg: - WHEN hTname x dbg ~> t THEN (data t)=(Tname x). -Proof. - wlp_simplify. -Qed. -Global Opaque hTname. -Hint Resolve hTname_correct: wlp. - -Definition hTop (o:op) (l: hashV list_tree) (debug: option pstring) : ?? hashV tree := - DO hc <~ hash 2;; - DO hv <~ hash o;; - hC_tree {| pre_data:=Top o (data l); - hcodes:=[hc;hv;hid l]; - debug_info := debug |}. - -Lemma hTop_correct o l dbg : - WHEN hTop o l dbg ~> t THEN (data t)=(Top o (data l)). -Proof. - wlp_simplify. -Qed. -Global Opaque hTop. -Hint Resolve hTop_correct: wlp. - -Definition hTnil (_: unit): ?? hashV list_tree := - hC_list_tree {| pre_data:=Tnil; hcodes := nil; debug_info := None |} . - -Lemma hTnil_correct x: - WHEN hTnil x ~> l THEN (data l)=Tnil. -Proof. - wlp_simplify. -Qed. -Global Opaque hTnil. -Hint Resolve hTnil_correct: wlp. - - -Definition hTcons (t: hashV tree) (l: hashV list_tree): ?? hashV list_tree := - hC_list_tree {| pre_data:=Tcons (data t) (data l); hcodes := [hid t; hid l]; debug_info := None |}. - -Lemma hTcons_correct t l: - WHEN hTcons t l ~> l' THEN (data l')=Tcons (data t) (data l). -Proof. - wlp_simplify. -Qed. -Global Opaque hTcons. -Hint Resolve hTcons_correct: wlp. - -(* Second, we use these hashed constructors ! *) - - -Record hdeps:= {hpre: list (hashV tree); hpost: Dict.t (hashV tree)}. - -Coercion hpost: hdeps >-> Dict.t. - -(* pseudo deps_get *) -Definition pdeps_get (d:Dict.t (hashV tree)) x : tree := - match Dict.get d x with - | None => Tname x - | Some t => (data t) - end. - -Definition hdeps_get (d:hdeps) x dbg : ?? hashV tree := - match Dict.get d x with - | None => hTname x dbg - | Some t => RET t - end. - -Lemma hdeps_get_correct (d:hdeps) x dbg: - WHEN hdeps_get d x dbg ~> t THEN (data t) = pdeps_get d x. -Proof. - unfold hdeps_get, pdeps_get; destruct (Dict.get d x); wlp_simplify. -Qed. -Global Opaque hdeps_get. -Hint Resolve hdeps_get_correct: wlp. - -Definition hdeps_valid ge (hd:hdeps) m := forall ht, List.In ht hd.(hpre) -> tree_eval ge (data ht) m <> None. - - -Definition deps_model ge (d: deps) (hd:hdeps): Prop := - (forall m, hdeps_valid ge hd m <-> valid ge d m) - /\ (forall m x, valid ge d m -> tree_eval ge (pdeps_get hd x) m = (deps_eval ge d x m)). - -Lemma deps_model_valid_alt ge d hd: deps_model ge d hd -> - forall m x, valid ge d m -> tree_eval ge (pdeps_get hd x) m <> None. -Proof. - intros (H1 & H2) m x H. rewrite H2; auto. - unfold valid in H. intuition eauto. -Qed. - -Lemma deps_model_hdeps_valid_alt ge d hd: deps_model ge d hd -> - forall m x, hdeps_valid ge hd m -> tree_eval ge (pdeps_get hd x) m <> None. -Proof. - intros (H1 & H2) m x H. eapply deps_model_valid_alt. - - split; eauto. - - rewrite <- H1; auto. -Qed. - -Fixpoint hexp_tree (e: exp) (d od: hdeps) (dbg: option pstring) : ?? hashV tree := - match e with - | PReg x => hdeps_get d x dbg - | Op o le => - DO lt <~ hlist_exp_tree le d od;; - hTop o lt dbg - | Old e => hexp_tree e od od dbg - end -with hlist_exp_tree (le: list_exp) (d od: hdeps): ?? hashV list_tree := - match le with - | Enil => hTnil tt - | Econs e le' => - DO t <~ hexp_tree e d od None;; - DO lt <~ hlist_exp_tree le' d od;; - hTcons t lt - | LOld le => hlist_exp_tree le od od - end. - -Lemma hexp_tree_correct_x ge e hod od: - deps_model ge od hod -> - forall hd d dbg, - deps_model ge d hd -> - WHEN hexp_tree e hd hod dbg ~> t THEN forall m, valid ge d m -> valid ge od m -> tree_eval ge (data t) m = tree_eval ge (exp_tree e d od) m. -Proof. - intro H. - induction e using exp_mut with (P0:=fun le => forall d hd, - deps_model ge d hd -> - WHEN hlist_exp_tree le hd hod ~> lt THEN forall m, valid ge d m -> valid ge od m -> list_tree_eval ge (data lt) m = list_tree_eval ge (list_exp_tree le d od) m); - unfold deps_model, deps_eval in * |- * ; simpl; wlp_simplify. - - rewrite H1, H4; auto. - - rewrite H4, <- H0; simpl; auto. - - rewrite H1; simpl; auto. - - rewrite H5, <- H0, <- H4; simpl; auto. -Qed. -Global Opaque hexp_tree. - -Lemma hexp_tree_correct e hd hod dbg: - WHEN hexp_tree e hd hod dbg ~> t THEN forall ge od d m, deps_model ge od hod -> deps_model ge d hd -> valid ge d m -> valid ge od m -> tree_eval ge (data t) m = tree_eval ge (exp_tree e d od) m. -Proof. - unfold wlp; intros; eapply hexp_tree_correct_x; eauto. -Qed. -Hint Resolve hexp_tree_correct: wlp. - -Definition failsafe (t: tree): bool := - match t with - | Tname x => true - | Top o Tnil => is_constant o - | _ => false - end. - -Local Hint Resolve is_constant_correct. - -Lemma failsafe_correct ge (t: tree) m: failsafe t = true -> tree_eval ge t m <> None. -Proof. - destruct t; simpl; try congruence. - destruct l; simpl; try congruence. - eauto. -Qed. -Local Hint Resolve failsafe_correct. - -Definition naive_set (hd:hdeps) x (t:hashV tree) := - {| hpre:= t::hd.(hpre); hpost:=Dict.set hd x t |}. - -Lemma naive_set_correct hd x ht ge d t: - deps_model ge d hd -> - (forall m, valid ge d m -> tree_eval ge (data ht) m = tree_eval ge t m) -> - deps_model ge (deps_set d x t) (naive_set hd x ht). -Proof. - unfold naive_set; intros (DM0 & DM1) EQT; split. - - intros m. - destruct (DM0 m) as (PRE & VALID0); clear DM0. - assert (VALID1: hdeps_valid ge hd m -> pre d ge m). { unfold valid in PRE; tauto. } - assert (VALID2: hdeps_valid ge hd m -> forall x : Dict.R.t, deps_eval ge d x m <> None). { unfold valid in PRE; tauto. } - unfold hdeps_valid in * |- *; simpl. - intuition (subst; eauto). - + eapply valid_set_proof; eauto. - erewrite <- EQT; eauto. - + exploit valid_set_decompose_1; eauto. - intros X1; exploit valid_set_decompose_2; eauto. - rewrite <- EQT; eauto. - + exploit valid_set_decompose_1; eauto. - - clear DM0. unfold deps_eval, pdeps_get, deps_get in * |- *; simpl. - Local Hint Resolve valid_set_decompose_1. - intros; case (R.eq_dec x x0). - + intros; subst; rewrite !Dict.set_spec_eq; simpl; eauto. - + intros; rewrite !Dict.set_spec_diff; simpl; eauto. -Qed. -Local Hint Resolve naive_set_correct. - -Definition equiv_hdeps ge (hd1 hd2: hdeps) := - (forall m, hdeps_valid ge hd1 m <-> hdeps_valid ge hd2 m) - /\ (forall m x, hdeps_valid ge hd1 m -> tree_eval ge (pdeps_get hd1 x) m = tree_eval ge (pdeps_get hd2 x) m). - -Lemma equiv_deps_symmetry ge hd1 hd2: - equiv_hdeps ge hd1 hd2 -> equiv_hdeps ge hd2 hd1. -Proof. - intros (V1 & P1); split. - - intros; symmetry; auto. - - intros; symmetry; eapply P1. rewrite V1; auto. -Qed. - -Lemma equiv_hdeps_models ge hd1 hd2 d: - deps_model ge d hd1 -> equiv_hdeps ge hd1 hd2 -> deps_model ge d hd2. -Proof. - intros (VALID & EQUIV) (HEQUIV & PEQUIV); split. - - intros m; rewrite <- VALID; auto. symmetry; auto. - - intros m x H. rewrite <- EQUIV; auto. - rewrite PEQUIV; auto. - rewrite VALID; auto. -Qed. - -Definition hdeps_set (hd:hdeps) x (t:hashV tree) := - DO ot <~ hdeps_get hd x None;; - DO b <~ phys_eq ot t;; - if b then - RET hd - else - RET {| hpre:= if failsafe (data t) then hd.(hpre) else t::hd.(hpre); - hpost:=Dict.set hd x t |}. - -Lemma hdeps_set_correct hd x ht: - WHEN hdeps_set hd x ht ~> nhd THEN - forall ge d t, deps_model ge d hd -> - (forall m, valid ge d m -> tree_eval ge (data ht) m = tree_eval ge t m) -> - deps_model ge (deps_set d x t) nhd. -Proof. - intros; wlp_simplify; eapply equiv_hdeps_models; eauto; unfold equiv_hdeps, hdeps_valid; simpl. - + split; eauto. - * intros m; split. - - intros X1 ht0 X2; apply X1; auto. - - intros X1 ht0 [Y1 | Y1]. subst. - rewrite H; eapply deps_model_hdeps_valid_alt; eauto. - eauto. - * intros m x0 X1. case (R.eq_dec x x0). - - intros; subst. unfold pdeps_get at 1. rewrite Dict.set_spec_eq. congruence. - - intros; unfold pdeps_get; rewrite Dict.set_spec_diff; auto. - + split; eauto. intros m. - generalize (failsafe_correct ge (data ht) m); intros FAILSAFE. - destruct (failsafe _); simpl; intuition (subst; eauto). -Qed. -Local Hint Resolve hdeps_set_correct: wlp. -Global Opaque hdeps_set. - -Variable debug_assign: R.t -> ?? option pstring. - -Fixpoint hinst_deps (i: inst) (d od: hdeps): ?? hdeps := - match i with - | nil => RET d - | (x, e)::i' => - DO dbg <~ debug_assign x;; - DO ht <~ hexp_tree e d od dbg;; - DO nd <~ hdeps_set d x ht;; - hinst_deps i' nd od - end. - - -Lemma hinst_deps_correct i: forall hd hod, - WHEN hinst_deps i hd hod ~> hd' THEN - forall ge od d, deps_model ge od hod -> deps_model ge d hd -> (forall m, valid ge d m -> valid ge od m) -> deps_model ge (inst_deps i d od) hd'. -Proof. - Local Hint Resolve valid_set_proof. - induction i; simpl; wlp_simplify; eauto 20. -Qed. -Global Opaque hinst_deps. -Local Hint Resolve hinst_deps_correct: wlp. - -(* logging info: we log the number of inst-instructions passed ! *) -Variable log: unit -> ?? unit. - -Fixpoint hbblock_deps_rec (p: bblock) (d: hdeps): ?? hdeps := - match p with - | nil => RET d - | i::p' => - log tt;; - DO d' <~ hinst_deps i d d;; - hbblock_deps_rec p' d' - end. - -Lemma hbblock_deps_rec_correct p: forall hd, - WHEN hbblock_deps_rec p hd ~> hd' THEN forall ge d, deps_model ge d hd -> deps_model ge (bblock_deps_rec p d) hd'. -Proof. - induction p; simpl; wlp_simplify. -Qed. -Global Opaque hbblock_deps_rec. -Local Hint Resolve hbblock_deps_rec_correct: wlp. - - -Definition hbblock_deps: bblock -> ?? hdeps - := fun p => hbblock_deps_rec p {| hpre:= nil ; hpost := Dict.empty |}. - -Lemma hbblock_deps_correct p: - WHEN hbblock_deps p ~> hd THEN forall ge, deps_model ge (bblock_deps p) hd. -Proof. - unfold bblock_deps; wlp_simplify. eapply H. clear H. - unfold deps_model, valid, pdeps_get, hdeps_valid, deps_eval, deps_get; simpl; intuition; - rewrite !Dict.empty_spec in * |- *; simpl in * |- *; try congruence. -Qed. -Global Opaque hbblock_deps. - -End CanonBuilding. - -(* Now, we build the hash-Cons value from a "hash_eq". - -Informal specification: - [hash_eq] must be consistent with the "hashed" constructors defined above. - -We expect that pre_hashV values in the code of these "hashed" constructors verify: - - (hash_eq (pre_data x) (pre_data y) ~> true) <-> (hcodes x)=(hcodes y) - -*) - -Definition tree_hash_eq (ta tb: tree): ?? bool := - match ta, tb with - | Tname xa, Tname xb => - if R.eq_dec xa xb (* Inefficient in some cases ? *) - then RET true - else RET false - | Top oa lta, Top ob ltb => - DO b <~ op_eq oa ob ;; - if b then phys_eq lta ltb - else RET false - | _,_ => RET false - end. - -Local Hint Resolve op_eq_correct: wlp. - -Lemma tree_hash_eq_correct: forall ta tb, WHEN tree_hash_eq ta tb ~> b THEN b=true -> ta=tb. -Proof. - destruct ta, tb; wlp_simplify; (discriminate || (subst; auto)). -Qed. -Global Opaque tree_hash_eq. -Hint Resolve tree_hash_eq_correct: wlp. - -Definition list_tree_hash_eq (lta ltb: list_tree): ?? bool := - match lta, ltb with - | Tnil, Tnil => RET true - | Tcons ta lta, Tcons tb ltb => - DO b <~ phys_eq ta tb ;; - if b then phys_eq lta ltb - else RET false - | _,_ => RET false - end. - -Lemma list_tree_hash_eq_correct: forall lta ltb, WHEN list_tree_hash_eq lta ltb ~> b THEN b=true -> lta=ltb. -Proof. - destruct lta, ltb; wlp_simplify; (discriminate || (subst; auto)). -Qed. -Global Opaque list_tree_hash_eq. -Hint Resolve list_tree_hash_eq_correct: wlp. - -Lemma pdeps_get_intro (d1 d2: hdeps): - (forall x, Dict.get d1 x = Dict.get d2 x) -> (forall x, pdeps_get d1 x = pdeps_get d2 x). -Proof. - unfold pdeps_get; intros H x; rewrite H. destruct (Dict.get d2 x); auto. -Qed. - -Local Hint Resolve hbblock_deps_correct Dict.eq_test_correct: wlp. - -(* TODO: - A REVOIR pour que Dict.test_eq qui soit insensible aux infos de debug ! - (cf. definition ci-dessous). - Il faut pour généraliser hash_params sur des Setoid (et les Dict aussi, avec ListSetoid, etc)... - *) -Program Definition mk_hash_params (log: hashV tree -> ?? unit): Dict.hash_params (hashV tree) := - {| (* Dict.test_eq := fun (ht1 ht2: hashV tree) => phys_eq (data ht1) (data ht2); *) - Dict.test_eq := phys_eq; - Dict.hashing := fun (ht: hashV tree) => RET (hid ht); - Dict.log := log |}. -Obligation 1. - eauto with wlp. -Qed. - -(*** A GENERIC EQ_TEST: IN ORDER TO SUPPORT SEVERAL DEBUGGING MODE !!! ***) - -Section Prog_Eq_Gen. - -Variable dbg1: R.t -> ?? option pstring. (* debugging of p1 insts *) -Variable dbg2: R.t -> ?? option pstring. (* log of p2 insts *) -Variable log1: unit -> ?? unit. (* log of p1 insts *) -Variable log2: unit -> ?? unit. (* log of p2 insts *) - -Variable hco_tree: hashConsing tree. -Hypothesis hco_tree_correct: hCons_spec hco_tree. -Variable hco_list: hashConsing list_tree. -Hypothesis hco_list_correct: hCons_spec hco_list. - -Variable print_error_end: hdeps -> hdeps -> ?? unit. -Variable print_error: pstring -> ?? unit. - -Variable check_failpreserv: bool. -Variable dbg_failpreserv: hashV tree -> ?? unit. (* info of additional failure of the output bbloc p2 wrt the input bbloc p1 *) - -Program Definition g_bblock_simu_test (p1 p2: bblock): ?? bool := - DO failure_in_failpreserv <~ make_cref false;; - DO r <~ (TRY - DO d1 <~ hbblock_deps (hC hco_tree) (hC hco_list) dbg1 log1 p1 ;; - DO d2 <~ hbblock_deps (hC_known hco_tree) (hC_known hco_list) dbg2 log2 p2 ;; - DO b <~ Dict.eq_test d1 d2 ;; - if b then ( - if check_failpreserv then ( - let hp := mk_hash_params dbg_failpreserv in - failure_in_failpreserv.(set)(true);; - Sets.assert_list_incl hp d2.(hpre) d1.(hpre);; - RET true - ) else RET false - ) else ( - print_error_end d1 d2 ;; - RET false - ) - CATCH_FAIL s, _ => - DO b <~ failure_in_failpreserv.(get)();; - if b then RET false - else print_error s;; RET false - ENSURE (fun b => b=true -> forall ge, bblock_simu ge p1 p2));; - RET (`r). -Obligation 1. - destruct hco_tree_correct as [TEQ1 TEQ2], hco_list_correct as [LEQ1 LEQ2]. - constructor 1; wlp_simplify; try congruence. - destruct (H ge) as (EQPRE1&EQPOST1); destruct (H0 ge) as (EQPRE2&EQPOST2); clear H H0. - apply bblock_deps_simu; auto. - + intros m; rewrite <- EQPRE1, <- EQPRE2. - unfold incl, hdeps_valid in * |- *; intuition eauto. - + intros m0 x m1 VALID; rewrite <- EQPOST1, <- EQPOST2; auto. - erewrite pdeps_get_intro; auto. - auto. - erewrite <- EQPRE2; auto. - erewrite <- EQPRE1 in VALID. - unfold incl, hdeps_valid in * |- *; intuition eauto. -Qed. - -Theorem g_bblock_simu_test_correct p1 p2: - WHEN g_bblock_simu_test p1 p2 ~> b THEN b=true -> forall ge, bblock_simu ge p1 p2. -Proof. - wlp_simplify. - destruct exta0; simpl in * |- *; auto. -Qed. -Global Opaque g_bblock_simu_test. - -End Prog_Eq_Gen. - - - -Definition skip (_:unit): ?? unit := RET tt. -Definition no_dbg (_:R.t): ?? option pstring := RET None. - - -Definition msg_prefix: pstring := "*** ERROR INFO from bblock_simu_test: ". -Definition msg_error_on_end: pstring := "mismatch in final assignments !". -Definition msg_unknow_tree: pstring := "unknown tree node". -Definition msg_unknow_list_tree: pstring := "unknown list node". -Definition msg_number: pstring := "on 2nd bblock -- on inst num ". -Definition msg_notfailpreserv: pstring := "a possible failure of 2nd bblock is absent in 1st bblock". - -Definition print_error_end (_ _: hdeps): ?? unit - := println (msg_prefix +; msg_error_on_end). - -Definition print_error (log: logger unit) (s:pstring): ?? unit - := DO n <~ log_info log ();; - println (msg_prefix +; msg_number +; n +; " -- " +; s). - -Definition failpreserv_error (_: hashV tree): ?? unit - := println (msg_prefix +; msg_notfailpreserv). - -Program Definition bblock_simu_test (p1 p2: bblock): ?? bool := - DO log <~ count_logger ();; - DO hco_tree <~ mk_annot (hCons tree_hash_eq (fun _ => RET msg_unknow_tree));; - DO hco_list <~ mk_annot (hCons list_tree_hash_eq (fun _ => RET msg_unknow_list_tree));; - g_bblock_simu_test - no_dbg - no_dbg - skip - (log_insert log) - hco_tree _ - hco_list _ - print_error_end - (print_error log) - true (* check_failpreserv *) - failpreserv_error - p1 p2. -Obligation 1. - generalize (hCons_correct _ _ _ _ H0); clear H0. - constructor 1; wlp_simplify. -Qed. -Obligation 2. - generalize (hCons_correct _ _ _ _ H); clear H. - constructor 1; wlp_simplify. -Qed. - -Local Hint Resolve g_bblock_simu_test_correct. - -Theorem bblock_simu_test_correct p1 p2: - WHEN bblock_simu_test p1 p2 ~> b THEN b=true -> forall ge, bblock_simu ge p1 p2. -Proof. - wlp_simplify. -Qed. -Global Opaque bblock_simu_test. - - - -(** This is only to print info on each bblock_simu_test run **) -Section Verbose_version. - -Variable string_of_name: R.t -> ?? pstring. -Variable string_of_op: op -> ?? pstring. - -Definition tree_id (id: caml_string): pstring := "E" +; (CamlStr id). -Definition list_id (id: caml_string): pstring := "L" +; (CamlStr id). - -Local Open Scope string_scope. - -Definition print_raw_htree (td: pre_hashV tree): ?? unit := - match pre_data td, hcodes td with - | (Tname x), _ => - DO s <~ string_of_name x;; - println( "init_access " +; s) - | (Top o Tnil), _ => - DO so <~ string_of_op o;; - println so - | (Top o _), [ _; _; lid ] => - DO so <~ string_of_op o;; - DO sl <~ string_of_hashcode lid;; - println (so +; " " +; (list_id sl)) - | _, _ => FAILWITH "unexpected hcodes" - end. - -Definition print_raw_hlist(ld: pre_hashV list_tree): ?? unit := - match pre_data ld, hcodes ld with - | Tnil, _ => println "" - | (Tcons _ _), [ t ; l ] => - DO st <~ string_of_hashcode t ;; - DO sl <~ string_of_hashcode l ;; - println((tree_id st) +; " " +; (list_id sl)) - | _, _ => FAILWITH "unexpected hcodes" - end. - -Section PrettryPrint. - -Variable get_htree: hashcode -> ?? pre_hashV tree. -Variable get_hlist: hashcode -> ?? pre_hashV list_tree. - -(* NB: requires [t = pre_data pt] *) -Fixpoint string_of_tree (t: tree) (pt: pre_hashV tree) : ?? pstring := - match debug_info pt with - | Some x => RET x - | None => - match t, hcodes pt with - | Tname x, _ => string_of_name x - | Top o Tnil, _ => string_of_op o - | Top o (_ as l), [ _; _; lid ] => - DO so <~ string_of_op o;; - DO pl <~ get_hlist lid;; - DO sl <~ string_of_list_tree l pl;; - RET (so +; "(" +; sl +; ")") - | _, _ => FAILWITH "unexpected hcodes" - end - end -(* NB: requires [l = pre_data pl] *) -with string_of_list_tree (l: list_tree) (lt: pre_hashV list_tree): ?? pstring := - match l, hcodes lt with - | Tnil, _ => RET (Str "") - | Tcons t Tnil, [ tid ; l ] => - DO pt <~ get_htree tid;; - string_of_tree t pt - | Tcons t l', [ tid ; lid' ] => - DO pt <~ get_htree tid;; - DO st <~ string_of_tree t pt;; - DO pl' <~ get_hlist lid';; - DO sl <~ string_of_list_tree l' pl';; - RET (st +; "," +; sl) - | _, _ => FAILWITH "unexpected hcodes" - end. - - -End PrettryPrint. - - -Definition pretty_tree ext exl pt := - DO r <~ string_of_tree (get_hashV ext) (get_hashV exl) (pre_data pt) pt;; - println(r). - -Fixpoint print_head (head: list pstring): ?? unit := - match head with - | i::head' => println ("--- inst " +; i);; print_head head' - | _ => RET tt - end. - -Definition print_htree ext exl (head: list pstring) (hid: hashcode) (td: pre_hashV tree): ?? unit := - print_head head;; - DO s <~ string_of_hashcode hid ;; - print ((tree_id s) +; ": ");; - print_raw_htree td;; - match debug_info td with - | Some x => - print("// " +; x +; " <- ");; - pretty_tree ext exl {| pre_data:=(pre_data td); hcodes:=(hcodes td); debug_info:=None |} - | None => RET tt - end. - -Definition print_hlist (head: list pstring) (hid: hashcode) (ld: pre_hashV list_tree): ?? unit := - print_head head;; - DO s <~ string_of_hashcode hid ;; - print ((list_id s) +; ": ");; - print_raw_hlist ld. - -Definition print_tables ext exl: ?? unit := - println "-- tree table --" ;; - iterall ext (print_htree ext exl);; - println "-- list table --" ;; - iterall exl print_hlist;; - println "----------------". - -Definition print_final_debug ext exl (d1 d2: hdeps): ?? unit - := DO b <~ Dict.not_eq_witness d1 d2 ;; - match b with - | Some x => - DO s <~ string_of_name x;; - println("mismatch on: " +; s);; - match Dict.get d1 x with - | None => println("=> unassigned in 1st bblock") - | Some ht1 => - print("=> node expected from 1st bblock: ");; - DO pt1 <~ get_hashV ext (hid ht1);; - pretty_tree ext exl pt1 - end;; - match Dict.get d2 x with - | None => println("=> unassigned in 2nd bblock") - | Some ht2 => - print("=> node found from 2nd bblock: ");; - DO pt2 <~ get_hashV ext (hid ht2);; - pretty_tree ext exl pt2 - end - | None => FAILWITH "bug in Dict.not_eq_witness ?" - end. - -Inductive witness:= - | Htree (pt: pre_hashV tree) - | Hlist (pl: pre_hashV list_tree) - | Nothing - . - -Definition msg_tree (cr: cref witness) td := - set cr (Htree td);; - RET msg_unknow_tree. - -Definition msg_list (cr: cref witness) tl := - set cr (Hlist tl);; - RET msg_unknow_list_tree. - -Definition print_witness ext exl cr msg := - DO wit <~ get cr ();; - match wit with - | Htree pt => - println("=> unknown tree node: ");; - pretty_tree ext exl {| pre_data:=(pre_data pt); hcodes:=(hcodes pt); debug_info:=None |};; - println("=> encoded on " +; msg +; " graph as: ");; - print_raw_htree pt - | Hlist pl => - println("=> unknown list node: ");; - DO r <~ string_of_list_tree (get_hashV ext) (get_hashV exl) (pre_data pl) pl;; - println(r);; - println("=> encoded on " +; msg +; " graph as: ");; - print_raw_hlist pl - | _ => println "Unexpected failure: no witness info (hint: hash-consing bug ?)" - end. - - -Definition print_error_end1 hct hcl (d1 d2:hdeps): ?? unit - := println "- GRAPH of 1st bblock";; - DO ext <~ export hct ();; - DO exl <~ export hcl ();; - print_tables ext exl;; - print_error_end d1 d2;; - print_final_debug ext exl d1 d2. - -Definition print_error1 hct hcl cr log s : ?? unit - := println "- GRAPH of 1st bblock";; - DO ext <~ export hct ();; - DO exl <~ export hcl ();; - print_tables ext exl;; - print_error log s;; - print_witness ext exl cr "1st". - - -Definition xmsg_number: pstring := "on 1st bblock -- on inst num ". - -Definition print_error_end2 hct hcl (d1 d2:hdeps): ?? unit - := println (msg_prefix +; msg_error_on_end);; - println "- GRAPH of 2nd bblock";; - DO ext <~ export hct ();; - DO exl <~ export hcl ();; - print_tables ext exl. - -Definition print_error2 hct hcl cr (log: logger unit) (s:pstring): ?? unit - := DO n <~ log_info log ();; - DO ext <~ export hct ();; - DO exl <~ export hcl ();; - println (msg_prefix +; xmsg_number +; n +; " -- " +; s);; - print_witness ext exl cr "2nd";; - println "- GRAPH of 2nd bblock";; - print_tables ext exl. - -Definition simple_debug (x: R.t): ?? option pstring := - DO s <~ string_of_name x;; - RET (Some s). - -Definition log_debug (log: logger unit) (x: R.t): ?? option pstring := - DO i <~ log_info log ();; - DO sx <~ string_of_name x;; - RET (Some (sx +; "@" +; i)). - -Definition hlog (log: logger unit) (hct: hashConsing tree) (hcl: hashConsing list_tree): unit -> ?? unit := - (fun _ => - log_insert log tt ;; - DO s <~ log_info log tt;; - next_log hct s;; - next_log hcl s - ). - -Program Definition verb_bblock_simu_test (p1 p2: bblock): ?? bool := - DO log1 <~ count_logger ();; - DO log2 <~ count_logger ();; - DO cr <~ make_cref Nothing;; - DO hco_tree <~ mk_annot (hCons tree_hash_eq (msg_tree cr));; - DO hco_list <~ mk_annot (hCons list_tree_hash_eq (msg_list cr));; - DO result1 <~ g_bblock_simu_test - (log_debug log1) - simple_debug - (hlog log1 hco_tree hco_list) - (log_insert log2) - hco_tree _ - hco_list _ - (print_error_end1 hco_tree hco_list) - (print_error1 hco_tree hco_list cr log2) - true - failpreserv_error (* TODO: debug info *) - p1 p2;; - if result1 - then RET true - else - DO log1 <~ count_logger ();; - DO log2 <~ count_logger ();; - DO cr <~ make_cref Nothing;; - DO hco_tree <~ mk_annot (hCons tree_hash_eq (msg_tree cr));; - DO hco_list <~ mk_annot (hCons list_tree_hash_eq (msg_list cr));; - DO result2 <~ g_bblock_simu_test - (log_debug log1) - simple_debug - (hlog log1 hco_tree hco_list) - (log_insert log2) - hco_tree _ - hco_list _ - (print_error_end2 hco_tree hco_list) - (print_error2 hco_tree hco_list cr log2) - false - (fun _ => RET tt) - p2 p1;; - if result2 - then ( - println (msg_prefix +; " OOops - symmetry violation in bblock_simu_test => this is a bug of bblock_simu_test ??");; - RET false - ) else RET false - . -Obligation 1. - generalize (hCons_correct _ _ _ _ H0); clear H0. - constructor 1; wlp_simplify. -Qed. -Obligation 2. - generalize (hCons_correct _ _ _ _ H); clear H. - constructor 1; wlp_simplify. -Qed. -Obligation 3. - generalize (hCons_correct _ _ _ _ H0); clear H0. - constructor 1; wlp_simplify. -Qed. -Obligation 4. - generalize (hCons_correct _ _ _ _ H); clear H. - constructor 1; wlp_simplify. -Qed. - -Theorem verb_bblock_simu_test_correct p1 p2: - WHEN verb_bblock_simu_test p1 p2 ~> b THEN b=true -> forall ge, bblock_simu ge p1 p2. -Proof. - wlp_simplify. -Qed. -Global Opaque verb_bblock_simu_test. - -End Verbose_version. - - -End ImpDepTree. - -Require Import FMapPositive. - -Module ImpPosDict <: ImpDict with Module R:=Pos. - -Include PosDict. -Import PositiveMap. - -Fixpoint eq_test {A} (d1 d2: t A): ?? bool := - match d1, d2 with - | Leaf _, Leaf _ => RET true - | Node l1 (Some x1) r1, Node l2 (Some x2) r2 => - DO b0 <~ phys_eq x1 x2 ;; - if b0 then - DO b1 <~ eq_test l1 l2 ;; - if b1 then - eq_test r1 r2 - else - RET false - else - RET false - | Node l1 None r1, Node l2 None r2 => - DO b1 <~ eq_test l1 l2 ;; - if b1 then - eq_test r1 r2 - else - RET false - | _, _ => RET false - end. - -Lemma eq_test_correct A d1: forall (d2: t A), - WHEN eq_test d1 d2 ~> b THEN - b=true -> forall x, get d1 x = get d2 x. -Proof. - unfold get; induction d1 as [|l1 Hl1 [x1|] r1 Hr1]; destruct d2 as [|l2 [x2|] r2]; simpl; - wlp_simplify; (discriminate || (subst; destruct x; simpl; auto)). -Qed. -Global Opaque eq_test. - -(* ONLY FOR DEBUGGING INFO: get some key of a non-empty d *) -Fixpoint pick {A} (d: t A): ?? R.t := - match d with - | Leaf _ => FAILWITH "unexpected empty dictionary" - | Node _ (Some _) _ => RET xH - | Node (Leaf _) None r => - DO p <~ pick r;; - RET (xI p) - | Node l None _ => - DO p <~ pick l;; - RET (xO p) - end. - -(* ONLY FOR DEBUGGING INFO: find one variable on which d1 and d2 differs *) -Fixpoint not_eq_witness {A} (d1 d2: t A): ?? option R.t := - match d1, d2 with - | Leaf _, Leaf _ => RET None - | Node l1 (Some x1) r1, Node l2 (Some x2) r2 => - DO b0 <~ phys_eq x1 x2 ;; - if b0 then - DO b1 <~ not_eq_witness l1 l2;; - match b1 with - | None => - DO b2 <~ not_eq_witness r1 r2;; - match b2 with - | None => RET None - | Some p => RET (Some (xI p)) - end - | Some p => RET (Some (xO p)) - end - else - RET (Some xH) - | Node l1 None r1, Node l2 None r2 => - DO b1 <~ not_eq_witness l1 l2;; - match b1 with - | None => - DO b2 <~ not_eq_witness r1 r2;; - match b2 with - | None => RET None - | Some p => RET (Some (xI p)) - end - | Some p => RET (Some (xO p)) - end - | l, Leaf _ => DO p <~ pick l;; RET (Some p) - | Leaf _, r => DO p <~ pick r;; RET (Some p) - | _, _ => RET (Some xH) - end. - -End ImpPosDict. - diff --git a/mppa_k1c/abstractbb/ImpSimuTest.v b/mppa_k1c/abstractbb/ImpSimuTest.v new file mode 100644 index 00000000..7a77ec15 --- /dev/null +++ b/mppa_k1c/abstractbb/ImpSimuTest.v @@ -0,0 +1,1246 @@ +(** Implementation of a symbolic execution of sequential semantics of Abstract Basic Blocks + +with imperative hash-consing, and rewriting. + +*) + +Require Export Impure.ImpHCons. +Export Notations. +Import HConsing. + + +Require Export SeqSimuTheory. + +Require Import PArith. + + +Local Open Scope impure. + +Import ListNotations. +Local Open Scope list_scope. + + +Module Type ImpParam. + +Include LangParam. + +Parameter op_eq: op -> op -> ?? bool. + +Parameter op_eq_correct: forall o1 o2, + WHEN op_eq o1 o2 ~> b THEN + b=true -> o1 = o2. + +End ImpParam. + + +Module Type ISeqLanguage. + +Declare Module LP: ImpParam. + +Include MkSeqLanguage LP. + +End ISeqLanguage. + + +Module Type ImpDict. + +Declare Module R: PseudoRegisters. + +Parameter t: Type -> Type. + +Parameter get: forall {A}, t A -> R.t -> option A. + +Parameter set: forall {A}, t A -> R.t -> A -> t A. + +Parameter set_spec_eq: forall A d x (v: A), + get (set d x v) x = Some v. + +Parameter set_spec_diff: forall A d x y (v: A), + x <> y -> get (set d x v) y = get d y. + +Parameter rem: forall {A}, t A -> R.t -> t A. + +Parameter rem_spec_eq: forall A (d: t A) x, + get (rem d x) x = None. + +Parameter rem_spec_diff: forall A (d: t A) x y, + x <> y -> get (rem d x) y = get d y. + +Parameter empty: forall {A}, t A. + +Parameter empty_spec: forall A x, + get (empty (A:=A)) x = None. + +Parameter eq_test: forall {A}, t A -> t A -> ?? bool. + +Parameter eq_test_correct: forall A (d1 d2: t A), + WHEN eq_test d1 d2 ~> b THEN + b=true -> forall x, get d1 x = get d2 x. + +(* NB: we could also take an eq_test on R.t (but not really useful with "pure" dictionaries *) + + +(* only for debugging *) +Parameter not_eq_witness: forall {A}, t A -> t A -> ?? option R.t. + +End ImpDict. + + +Module Type ImpSimuInterface. + +Declare Module CoreL: ISeqLanguage. +Import CoreL. +Import Terms. + +Parameter bblock_simu_test: reduction -> bblock -> bblock -> ?? bool. + +Parameter bblock_simu_test_correct: forall reduce (p1 p2 : bblock), + WHEN bblock_simu_test reduce p1 p2 ~> b + THEN b = true -> forall ge : genv, bblock_simu ge p1 p2. + + +Parameter verb_bblock_simu_test + : reduction -> + (R.t -> ?? pstring) -> + (op -> ?? pstring) -> bblock -> bblock -> ?? bool. + +Parameter verb_bblock_simu_test_correct: + forall reduce + (string_of_name : R.t -> ?? pstring) + (string_of_op : op -> ?? pstring) + (p1 p2 : bblock), + WHEN verb_bblock_simu_test reduce string_of_name string_of_op p1 p2 ~> b + THEN b = true -> forall ge : genv, bblock_simu ge p1 p2. + +End ImpSimuInterface. + + + +Module ImpSimu (L: ISeqLanguage) (Dict: ImpDict with Module R:=L.LP.R): ImpSimuInterface with Module CoreL := L. + +Module CoreL:=L. + +Module ST := SimuTheory L. + +Import ST. +Import Terms. + +Definition term_set_hid (t: term) (hid: hashcode): term := + match t with + | Input x _ => Input x hid + | App op l _ => App op l hid + end. + +Definition list_term_set_hid (l: list_term) (hid: hashcode): list_term := + match l with + | LTnil _ => LTnil hid + | LTcons t l' _ => LTcons t l' hid + end. + +Lemma term_eval_set_hid ge t hid m: + term_eval ge (term_set_hid t hid) m = term_eval ge t m. +Proof. + destruct t; simpl; auto. +Qed. + +Lemma list_term_eval_set_hid ge l hid m: + list_term_eval ge (list_term_set_hid l hid) m = list_term_eval ge l m. +Proof. + destruct l; simpl; auto. +Qed. + +(* Local nickname *) +Module D:=ImpPrelude.Dict. + +Section SimuWithReduce. + +Variable reduce: reduction. + +Section CanonBuilding. + +Variable hC_term: hashinfo term -> ?? term. +Hypothesis hC_term_correct: forall t, WHEN hC_term t ~> t' THEN forall ge m, term_eval ge (hdata t) m = term_eval ge t' m. + +Variable hC_list_term: hashinfo list_term -> ?? list_term. +Hypothesis hC_list_term_correct: forall t, WHEN hC_list_term t ~> t' THEN forall ge m, list_term_eval ge (hdata t) m = list_term_eval ge t' m. + +(* First, we wrap constructors for hashed values !*) + +Local Open Scope positive. +Local Open Scope list_scope. + +Definition hInput_hcodes (x:R.t) := + DO hc <~ hash 1;; + DO hv <~ hash x;; + RET [hc;hv]. +Extraction Inline hInput_hcodes. + +Definition hInput (x:R.t): ?? term := + DO hv <~ hInput_hcodes x;; + hC_term {| hdata:=Input x unknown_hid; hcodes :=hv; |}. + +Lemma hInput_correct x: + WHEN hInput x ~> t THEN forall ge m, term_eval ge t m = Some (m x). +Proof. + wlp_simplify. +Qed. +Global Opaque hInput. +Hint Resolve hInput_correct: wlp. + +Definition hApp_hcodes (o:op) (l: list_term) := + DO hc <~ hash 2;; + DO hv <~ hash o;; + RET [hc;hv;list_term_get_hid l]. +Extraction Inline hApp_hcodes. + +Definition hApp (o:op) (l: list_term) : ?? term := + DO hv <~ hApp_hcodes o l;; + hC_term {| hdata:=App o l unknown_hid; hcodes:=hv |}. + +Lemma hApp_correct o l: + WHEN hApp o l ~> t THEN forall ge m, + term_eval ge t m = match list_term_eval ge l m with + | Some v => op_eval ge o v + | None => None + end. +Proof. + wlp_simplify. +Qed. +Global Opaque hApp. +Hint Resolve hApp_correct: wlp. + +Definition hLTnil (_: unit): ?? list_term := + hC_list_term {| hdata:=LTnil unknown_hid; hcodes := nil; |} . + +Lemma hLTnil_correct x: + WHEN hLTnil x ~> l THEN forall ge m, list_term_eval ge l m = Some nil. +Proof. + wlp_simplify. +Qed. +Global Opaque hLTnil. +Hint Resolve hLTnil_correct: wlp. + + +Definition hLTcons (t: term) (l: list_term): ?? list_term := + hC_list_term {| hdata:=LTcons t l unknown_hid; hcodes := [term_get_hid t; list_term_get_hid l]; |}. + +Lemma hLTcons_correct t l: + WHEN hLTcons t l ~> l' THEN forall ge m, + list_term_eval ge l' m = match term_eval ge t m, list_term_eval ge l m with + | Some v, Some lv => Some (v::lv) + | _, _ => None + end. +Proof. + wlp_simplify. +Qed. +Global Opaque hLTcons. +Hint Resolve hLTcons_correct: wlp. + +(* Second, we use these hashed constructors ! *) + +Record hsmem:= {hpre: list term; hpost:> Dict.t term}. + +(** evaluation of the post-condition *) +Definition hsmem_post_eval ge (hd: Dict.t term) x (m:mem) := + match Dict.get hd x with + | None => Some (m x) + | Some ht => term_eval ge ht m + end. + +Definition hsmem_get (d:hsmem) x: ?? term := + match Dict.get d x with + | None => hInput x + | Some t => RET t + end. + +Lemma hsmem_get_correct (d:hsmem) x: + WHEN hsmem_get d x ~> t THEN forall ge m, term_eval ge t m = hsmem_post_eval ge d x m. +Proof. + unfold hsmem_get, hsmem_post_eval; destruct (Dict.get d x); wlp_simplify. +Qed. +Global Opaque hsmem_get. +Hint Resolve hsmem_get_correct: wlp. + +Local Opaque allvalid. + +Definition smem_model ge (d: smem) (hd:hsmem): Prop := + (forall m, allvalid ge hd.(hpre) m <-> smem_valid ge d m) + /\ (forall m x, smem_valid ge d m -> hsmem_post_eval ge hd x m = (ST.term_eval ge (d x) m)). + +Lemma smem_model_smem_valid_alt ge d hd: smem_model ge d hd -> + forall m x, smem_valid ge d m -> hsmem_post_eval ge hd x m <> None. +Proof. + intros (H1 & H2) m x H. rewrite H2; auto. + unfold smem_valid in H. intuition eauto. +Qed. + +Lemma smem_model_allvalid_alt ge d hd: smem_model ge d hd -> + forall m x, allvalid ge hd.(hpre) m -> hsmem_post_eval ge hd x m <> None. +Proof. + intros (H1 & H2) m x H. eapply smem_model_smem_valid_alt. + - split; eauto. + - rewrite <- H1; auto. +Qed. + +Definition naive_set (hd:hsmem) x (t:term) := + {| hpre:= t::hd.(hpre); hpost:=Dict.set hd x t |}. + +Lemma naive_set_correct hd x ht ge d t: + smem_model ge d hd -> + (forall m, smem_valid ge d m -> term_eval ge ht m = ST.term_eval ge t m) -> + smem_model ge (smem_set d x t) (naive_set hd x ht). +Proof. + unfold naive_set; intros (DM0 & DM1) EQT; split. + - intros m. + destruct (DM0 m) as (PRE & VALID0); clear DM0. + assert (VALID1: allvalid ge hd.(hpre) m -> pre d ge m). { unfold smem_valid in PRE; tauto. } + assert (VALID2: allvalid ge hd.(hpre) m -> forall x : Dict.R.t, ST.term_eval ge (d x) m <> None). { unfold smem_valid in PRE; tauto. } + rewrite !allvalid_extensionality in * |- *; simpl. + intuition (subst; eauto). + + eapply smem_valid_set_proof; eauto. + erewrite <- EQT; eauto. + + exploit smem_valid_set_decompose_1; eauto. + intros X1; exploit smem_valid_set_decompose_2; eauto. + rewrite <- EQT; eauto. + + exploit smem_valid_set_decompose_1; eauto. + - clear DM0. unfold hsmem_post_eval, hsmem_post_eval in * |- *; simpl. + Local Hint Resolve smem_valid_set_decompose_1: core. + intros; case (R.eq_dec x x0). + + intros; subst; rewrite !Dict.set_spec_eq; simpl; eauto. + + intros; rewrite !Dict.set_spec_diff; simpl; eauto. +Qed. +Local Hint Resolve naive_set_correct: core. + +Definition equiv_hsmem ge (hd1 hd2: hsmem) := + (forall m, allvalid ge hd1.(hpre) m <-> allvalid ge hd2.(hpre) m) + /\ (forall m x, allvalid ge hd1.(hpre) m -> hsmem_post_eval ge hd1 x m = hsmem_post_eval ge hd2 x m). + +Lemma equiv_smem_symmetry ge hd1 hd2: + equiv_hsmem ge hd1 hd2 -> equiv_hsmem ge hd2 hd1. +Proof. + intros (V1 & P1); split. + - intros; symmetry; auto. + - intros; symmetry; eapply P1. rewrite V1; auto. +Qed. + +Lemma equiv_hsmem_models ge hd1 hd2 d: + smem_model ge d hd1 -> equiv_hsmem ge hd1 hd2 -> smem_model ge d hd2. +Proof. + intros (VALID & EQUIV) (HEQUIV & PEQUIV); split. + - intros m; rewrite <- VALID; auto. symmetry; auto. + - intros m x H. rewrite <- EQUIV; auto. + rewrite PEQUIV; auto. + rewrite VALID; auto. +Qed. + +Variable log_assign: R.t -> term -> ?? unit. + +Definition lift {A B} hid (x:A) (k: B -> ?? A) (y:B): ?? A := + DO b <~ phys_eq hid unknown_hid;; + if b then k y else RET x. + +Fixpoint hterm_lift (t: term): ?? term := + match t with + | Input x hid => lift hid t hInput x + | App o l hid => + lift hid t + (fun l => DO lt <~ hlist_term_lift l;; + hApp o lt) l + end +with hlist_term_lift (l: list_term) {struct l}: ?? list_term := + match l with + | LTnil hid => lift hid l hLTnil () + | LTcons t l' hid => + lift hid l + (fun t => DO t <~ hterm_lift t;; + DO lt <~ hlist_term_lift l';; + hLTcons t lt) t + end. + +Lemma hterm_lift_correct t: + WHEN hterm_lift t ~> ht THEN forall ge m, term_eval ge ht m = term_eval ge t m. +Proof. + induction t using term_mut with (P0:=fun lt => + WHEN hlist_term_lift lt ~> hlt THEN forall ge m, list_term_eval ge hlt m = list_term_eval ge lt m); + wlp_simplify. + - rewrite H0, H; auto. + - rewrite H1, H0, H; auto. +Qed. +Local Hint Resolve hterm_lift_correct: wlp. +Global Opaque hterm_lift. + +Variable log_new_hterm: term -> ?? unit. + +Fixpoint hterm_append (l: list term) (lh: list term): ?? list term := + match l with + | nil => RET lh + | t::l' => + DO ht <~ hterm_lift t;; + log_new_hterm ht;; + hterm_append l' (ht::lh) + end. + +Lemma hterm_append_correct l: forall lh, + WHEN hterm_append l lh ~> lh' THEN (forall ge m, allvalid ge lh' m <-> (allvalid ge l m /\ allvalid ge lh m)). +Proof. + Local Hint Resolve eq_trans: localhint. + induction l as [|t l']; simpl; wlp_xsimplify ltac:(eauto with wlp). + - intros; rewrite! allvalid_extensionality; intuition eauto. + - intros REC ge m; rewrite REC; clear IHl' REC. rewrite !allvalid_extensionality. + simpl; intuition (subst; eauto with wlp localhint). +Qed. +(*Local Hint Resolve hterm_append_correct: wlp.*) +Global Opaque hterm_append. + +Definition smart_set (hd:hsmem) x (ht:term) := + match ht with + | Input y _ => + if R.eq_dec x y then + RET (Dict.rem hd x) + else ( + log_assign x ht;; + RET (Dict.set hd x ht) + ) + | _ => + log_assign x ht;; + RET (Dict.set hd x ht) + end. + +Lemma smart_set_correct hd x ht: + WHEN smart_set hd x ht ~> d THEN + forall ge m y, hsmem_post_eval ge d y m = hsmem_post_eval ge (Dict.set hd x ht) y m. +Proof. + destruct ht; wlp_simplify. + unfold hsmem_post_eval; simpl. case (R.eq_dec x0 y). + - intros; subst. rewrite Dict.set_spec_eq, Dict.rem_spec_eq. simpl; congruence. + - intros; rewrite Dict.set_spec_diff, Dict.rem_spec_diff; auto. +Qed. +(*Local Hint Resolve smart_set_correct: wlp.*) +Global Opaque smart_set. + +Definition hsmem_set (hd:hsmem) x (t:term) := + DO pt <~ reduce t;; + DO lht <~ hterm_append pt.(mayfail) hd.(hpre);; + DO ht <~ hterm_lift pt.(effect);; + log_new_hterm ht;; + DO nd <~ smart_set hd x ht;; + RET {| hpre := lht; hpost := nd |}. + +Lemma hsmem_set_correct hd x ht: + WHEN hsmem_set hd x ht ~> nhd THEN + forall ge d t, smem_model ge d hd -> + (forall m, smem_valid ge d m -> term_eval ge ht m = ST.term_eval ge t m) -> + smem_model ge (smem_set d x t) nhd. +Proof. + intros; wlp_simplify. + generalize (hterm_append_correct _ _ _ Hexta0); intro APPEND. + generalize (hterm_lift_correct _ _ Hexta1); intro LIFT. + generalize (smart_set_correct _ _ _ _ Hexta3); intro SMART. + eapply equiv_hsmem_models; eauto; unfold equiv_hsmem; simpl. + destruct H as (VALID & EFFECT); split. + - intros; rewrite APPEND, <- VALID. + rewrite !allvalid_extensionality in * |- *; simpl; intuition (subst; eauto). + - intros m x0 ALLVALID; rewrite SMART. + destruct (term_eval ge ht m) eqn: Hht. + * case (R.eq_dec x x0). + + intros; subst. unfold hsmem_post_eval; simpl. rewrite !Dict.set_spec_eq. + erewrite LIFT, EFFECT; eauto. + + intros; unfold hsmem_post_eval; simpl. rewrite !Dict.set_spec_diff; auto. + * rewrite allvalid_extensionality in ALLVALID; destruct (ALLVALID ht); simpl; auto. +Qed. +Local Hint Resolve hsmem_set_correct: wlp. +Global Opaque hsmem_set. + +(* VARIANTE: we do not hash-cons the term from the expression +Lemma exp_hterm_correct ge e hod od: + smem_model ge od hod -> + forall hd d, + smem_model ge d hd -> + forall m, smem_valid ge d m -> smem_valid ge od m -> term_eval ge (exp_term e hd hod) m = term_eval ge (exp_term e d od) m. +Proof. + intro H. + induction e using exp_mut with (P0:=fun le => forall d hd, + smem_model ge d hd -> forall m, smem_valid ge d m -> smem_valid ge od m -> list_term_eval ge (list_exp_term le hd hod) m = list_term_eval ge (list_exp_term le d od) m); + unfold smem_model in * |- * ; simpl; intuition eauto. + - erewrite IHe; eauto. + - erewrite IHe0, IHe; eauto. +Qed. +Local Hint Resolve exp_hterm_correct: wlp. +*) + +Fixpoint exp_hterm (e: exp) (hd hod: hsmem): ?? term := + match e with + | PReg x => hsmem_get hd x + | Op o le => + DO lt <~ list_exp_hterm le hd hod;; + hApp o lt + | Old e => exp_hterm e hod hod + end +with list_exp_hterm (le: list_exp) (hd hod: hsmem): ?? list_term := + match le with + | Enil => hLTnil tt + | Econs e le' => + DO t <~ exp_hterm e hd hod;; + DO lt <~ list_exp_hterm le' hd hod;; + hLTcons t lt + | LOld le => list_exp_hterm le hod hod + end. + +Lemma exp_hterm_correct_x ge e hod od: + smem_model ge od hod -> + forall hd d, + smem_model ge d hd -> + WHEN exp_hterm e hd hod ~> t THEN forall m, smem_valid ge d m -> smem_valid ge od m -> term_eval ge t m = ST.term_eval ge (exp_term e d od) m. + Proof. + intro H. + induction e using exp_mut with (P0:=fun le => forall d hd, + smem_model ge d hd -> + WHEN list_exp_hterm le hd hod ~> lt THEN forall m, smem_valid ge d m -> smem_valid ge od m -> list_term_eval ge lt m = ST.list_term_eval ge (list_exp_term le d od) m); + unfold smem_model, hsmem_post_eval in * |- * ; simpl; wlp_simplify. + - rewrite H1, <- H4; auto. + - rewrite H4, <- H0; simpl; auto. + - rewrite H5, <- H0, <- H4; simpl; auto. +Qed. +Global Opaque exp_hterm. + +Lemma exp_hterm_correct e hd hod: + WHEN exp_hterm e hd hod ~> t THEN forall ge od d m, smem_model ge od hod -> smem_model ge d hd -> smem_valid ge d m -> smem_valid ge od m -> term_eval ge t m = ST.term_eval ge (exp_term e d od) m. +Proof. + unfold wlp; intros; eapply exp_hterm_correct_x; eauto. +Qed. +Hint Resolve exp_hterm_correct: wlp. + +Fixpoint hinst_smem (i: inst) (hd hod: hsmem): ?? hsmem := + match i with + | nil => RET hd + | (x, e)::i' => + DO ht <~ exp_hterm e hd hod;; + DO nd <~ hsmem_set hd x ht;; + hinst_smem i' nd hod + end. + +Lemma hinst_smem_correct i: forall hd hod, + WHEN hinst_smem i hd hod ~> hd' THEN + forall ge od d, smem_model ge od hod -> smem_model ge d hd -> (forall m, smem_valid ge d m -> smem_valid ge od m) -> smem_model ge (inst_smem i d od) hd'. +Proof. + Local Hint Resolve smem_valid_set_proof: core. + induction i; simpl; wlp_simplify; eauto 15 with wlp. +Qed. +Global Opaque hinst_smem. +Local Hint Resolve hinst_smem_correct: wlp. + +(* logging info: we log the number of inst-instructions passed ! *) +Variable log_new_inst: unit -> ?? unit. + +Fixpoint bblock_hsmem_rec (p: bblock) (d: hsmem): ?? hsmem := + match p with + | nil => RET d + | i::p' => + log_new_inst tt;; + DO d' <~ hinst_smem i d d;; + bblock_hsmem_rec p' d' + end. + +Lemma bblock_hsmem_rec_correct p: forall hd, + WHEN bblock_hsmem_rec p hd ~> hd' THEN forall ge d, smem_model ge d hd -> smem_model ge (bblock_smem_rec p d) hd'. +Proof. + induction p; simpl; wlp_simplify. +Qed. +Global Opaque bblock_hsmem_rec. +Local Hint Resolve bblock_hsmem_rec_correct: wlp. + +Definition hsmem_empty: hsmem := {| hpre:= nil ; hpost := Dict.empty |}. + +Lemma hsmem_empty_correct ge: smem_model ge smem_empty hsmem_empty. +Proof. + unfold smem_model, smem_valid, hsmem_post_eval; simpl; intuition try congruence. + rewrite !Dict.empty_spec; simpl; auto. +Qed. + +Definition bblock_hsmem: bblock -> ?? hsmem + := fun p => bblock_hsmem_rec p hsmem_empty. + +Lemma bblock_hsmem_correct p: + WHEN bblock_hsmem p ~> hd THEN forall ge, smem_model ge (bblock_smem p) hd. +Proof. + Local Hint Resolve hsmem_empty_correct: core. + wlp_simplify. +Qed. +Global Opaque bblock_hsmem. + +End CanonBuilding. + +(* Now, we build the hash-Cons value from a "hash_eq". + +Informal specification: + [hash_eq] must be consistent with the "hashed" constructors defined above. + +We expect that hashinfo values in the code of these "hashed" constructors verify: + + (hash_eq (hdata x) (hdata y) ~> true) <-> (hcodes x)=(hcodes y) + +*) + +Definition term_hash_eq (ta tb: term): ?? bool := + match ta, tb with + | Input xa _, Input xb _ => + if R.eq_dec xa xb (* Inefficient in some cases ? *) + then RET true + else RET false + | App oa lta _, App ob ltb _ => + DO b <~ op_eq oa ob ;; + if b then phys_eq lta ltb + else RET false + | _,_ => RET false + end. + +Lemma term_hash_eq_correct: forall ta tb, WHEN term_hash_eq ta tb ~> b THEN b=true -> term_set_hid ta unknown_hid=term_set_hid tb unknown_hid. +Proof. + Local Hint Resolve op_eq_correct: wlp. + destruct ta, tb; wlp_simplify; (discriminate || (subst; auto)). +Qed. +Global Opaque term_hash_eq. +Hint Resolve term_hash_eq_correct: wlp. + +Definition list_term_hash_eq (lta ltb: list_term): ?? bool := + match lta, ltb with + | LTnil _, LTnil _ => RET true + | LTcons ta lta _, LTcons tb ltb _ => + DO b <~ phys_eq ta tb ;; + if b then phys_eq lta ltb + else RET false + | _,_ => RET false + end. + +Lemma list_term_hash_eq_correct: forall lta ltb, WHEN list_term_hash_eq lta ltb ~> b THEN b=true -> list_term_set_hid lta unknown_hid=list_term_set_hid ltb unknown_hid. +Proof. + destruct lta, ltb; wlp_simplify; (discriminate || (subst; auto)). +Qed. +Global Opaque list_term_hash_eq. +Hint Resolve list_term_hash_eq_correct: wlp. + +Lemma hsmem_post_eval_intro (d1 d2: hsmem): + (forall x, Dict.get d1 x = Dict.get d2 x) -> (forall ge x m, hsmem_post_eval ge d1 x m = hsmem_post_eval ge d2 x m). +Proof. + unfold hsmem_post_eval; intros H ge x m; rewrite H. destruct (Dict.get d2 x); auto. +Qed. + +Local Hint Resolve bblock_hsmem_correct Dict.eq_test_correct: wlp. + +Program Definition mk_hash_params (log: term -> ?? unit): Dict.hash_params term := + {| + Dict.test_eq := phys_eq; + Dict.hashing := fun (ht: term) => RET (term_get_hid ht); + Dict.log := log |}. +Obligation 1. + eauto with wlp. +Qed. + +(*** A GENERIC EQ_TEST: IN ORDER TO SUPPORT SEVERAL DEBUGGING MODE !!! ***) +Definition no_log_assign (x:R.t) (t:term): ?? unit := RET tt. +Definition no_log_new_term (t:term): ?? unit := RET tt. + +Section Prog_Eq_Gen. + +Variable log_assign: R.t -> term -> ?? unit. +Variable log_new_term: hashConsing term -> hashConsing list_term -> ??(term -> ?? unit). +Variable log_inst1: unit -> ?? unit. (* log of p1 insts *) +Variable log_inst2: unit -> ?? unit. (* log of p2 insts *) + +Variable hco_term: hashConsing term. +Hypothesis hco_term_correct: forall t, WHEN hco_term.(hC) t ~> t' THEN forall ge m, term_eval ge (hdata t) m = term_eval ge t' m. + +Variable hco_list: hashConsing list_term. +Hypothesis hco_list_correct: forall t, WHEN hco_list.(hC) t ~> t' THEN forall ge m, list_term_eval ge (hdata t) m = list_term_eval ge t' m. + +Variable print_error_end: hsmem -> hsmem -> ?? unit. +Variable print_error: pstring -> ?? unit. + +Variable check_failpreserv: bool. +Variable dbg_failpreserv: term -> ?? unit. (* info of additional failure of the output bbloc p2 wrt the input bbloc p1 *) + +Program Definition g_bblock_simu_test (p1 p2: bblock): ?? bool := + DO failure_in_failpreserv <~ make_cref false;; + DO r <~ (TRY + DO d1 <~ bblock_hsmem hco_term.(hC) hco_list.(hC) log_assign no_log_new_term log_inst1 p1;; + DO log_new_term <~ log_new_term hco_term hco_list;; + DO d2 <~ bblock_hsmem hco_term.(hC) hco_list.(hC) no_log_assign log_new_term log_inst2 p2;; + DO b <~ Dict.eq_test d1 d2 ;; + if b then ( + if check_failpreserv then ( + let hp := mk_hash_params dbg_failpreserv in + failure_in_failpreserv.(set)(true);; + Sets.assert_list_incl hp d2.(hpre) d1.(hpre);; + RET true + ) else RET false + ) else ( + print_error_end d1 d2 ;; + RET false + ) + CATCH_FAIL s, _ => + DO b <~ failure_in_failpreserv.(get)();; + if b then RET false + else print_error s;; RET false + ENSURE (fun b => b=true -> forall ge, bblock_simu ge p1 p2));; + RET (`r). +Obligation 1. + constructor 1; wlp_simplify; try congruence. + destruct (H ge) as (EQPRE1&EQPOST1); destruct (H0 ge) as (EQPRE2&EQPOST2); clear H H0. + apply bblock_smem_simu; auto. split. + + intros m; rewrite <- EQPRE1, <- EQPRE2. + rewrite ! allvalid_extensionality. + unfold incl in * |- *; intuition eauto. + + intros m0 x VALID; rewrite <- EQPOST1, <- EQPOST2; auto. + erewrite hsmem_post_eval_intro; eauto. + erewrite <- EQPRE2; auto. + erewrite <- EQPRE1 in VALID. + rewrite ! allvalid_extensionality in * |- *. + unfold incl in * |- *; intuition eauto. +Qed. + +Theorem g_bblock_simu_test_correct p1 p2: + WHEN g_bblock_simu_test p1 p2 ~> b THEN b=true -> forall ge, bblock_simu ge p1 p2. +Proof. + wlp_simplify. + destruct exta0; simpl in * |- *; auto. +Qed. +Global Opaque g_bblock_simu_test. + +End Prog_Eq_Gen. + + + +Definition hpt: hashP term := {| hash_eq := term_hash_eq; get_hid:=term_get_hid; set_hid:=term_set_hid |}. +Definition hplt: hashP list_term := {| hash_eq := list_term_hash_eq; get_hid:=list_term_get_hid; set_hid:=list_term_set_hid |}. + +Definition recover_hcodes (t:term): ??(hashinfo term) := + match t with + | Input x _ => + DO hv <~ hInput_hcodes x ;; + RET {| hdata := t; hcodes := hv |} + | App o l _ => + DO hv <~ hApp_hcodes o l ;; + RET {| hdata := t; hcodes := hv |} + end. + + +Definition msg_end_of_bblock: pstring :="--- unknown subterms in the graph". + +Definition log_new_term + (unknownHash_msg: term -> ?? pstring) + (hct:hashConsing term) + (hcl:hashConsing list_term) + : ?? (term -> ?? unit) := + DO clock <~ hct.(next_hid)();; + hct.(next_log) msg_end_of_bblock;; + hcl.(next_log) msg_end_of_bblock;; + RET (fun t => + DO ok <~ hash_older (term_get_hid t) clock;; + if ok + then + RET tt + else + DO ht <~ recover_hcodes t;; + hct.(remove) ht;; + DO msg <~ unknownHash_msg t;; + FAILWITH msg). + +Definition skip (_:unit): ?? unit := RET tt. + +Definition msg_prefix: pstring := "*** ERROR INFO from bblock_simu_test: ". +Definition msg_error_on_end: pstring := "mismatch in final assignments !". +Definition msg_unknow_term: pstring := "unknown term". +Definition msg_number: pstring := "on 2nd bblock -- on inst num ". +Definition msg_notfailpreserv: pstring := "a possible failure of 2nd bblock is absent in 1st bblock (INTERNAL ERROR: this error is expected to be detected before!!!)". + +Definition print_error_end (_ _: hsmem): ?? unit + := println (msg_prefix +; msg_error_on_end). + +Definition print_error (log: logger unit) (s:pstring): ?? unit + := DO n <~ log_info log ();; + println (msg_prefix +; msg_number +; n +; " -- " +; s). + +Definition failpreserv_error (_: term): ?? unit + := println (msg_prefix +; msg_notfailpreserv). + +Lemma term_eval_set_hid_equiv ge t1 t2 hid1 hid2 m: + term_set_hid t1 hid1 = term_set_hid t2 hid2 -> term_eval ge t1 m = term_eval ge t2 m. +Proof. + intro H; erewrite <- term_eval_set_hid; rewrite H. apply term_eval_set_hid. +Qed. + +Lemma list_term_eval_set_hid_equiv ge t1 t2 hid1 hid2 m: + list_term_set_hid t1 hid1 = list_term_set_hid t2 hid2 -> list_term_eval ge t1 m = list_term_eval ge t2 m. +Proof. + intro H; erewrite <- list_term_eval_set_hid; rewrite H. apply list_term_eval_set_hid. +Qed. + +Local Hint Resolve term_eval_set_hid_equiv list_term_eval_set_hid_equiv: core. + +Program Definition bblock_simu_test (p1 p2: bblock): ?? bool := + DO log <~ count_logger ();; + DO hco_term <~ mk_annot (hCons hpt);; + DO hco_list <~ mk_annot (hCons hplt);; + g_bblock_simu_test + no_log_assign + (log_new_term (fun _ => RET msg_unknow_term)) + skip + (log_insert log) + hco_term _ + hco_list _ + print_error_end + (print_error log) + true (* check_failpreserv *) + failpreserv_error + p1 p2. +Obligation 1. + generalize (hCons_correct _ _ _ H0); clear H0. + wlp_simplify. +Qed. +Obligation 2. + generalize (hCons_correct _ _ _ H); clear H. + wlp_simplify. +Qed. + +Local Hint Resolve g_bblock_simu_test_correct: core. + +Theorem bblock_simu_test_correct p1 p2: + WHEN bblock_simu_test p1 p2 ~> b THEN b=true -> forall ge, bblock_simu ge p1 p2. +Proof. + wlp_simplify. +Qed. +Global Opaque bblock_simu_test. + +(** This is only to print info on each bblock_simu_test run **) +Section Verbose_version. + +Variable string_of_name: R.t -> ?? pstring. +Variable string_of_op: op -> ?? pstring. + + +Local Open Scope string_scope. + +Definition string_term_hid (t: term): ?? pstring := + DO id <~ string_of_hashcode (term_get_hid t);; + RET ("E" +; (CamlStr id)). + +Definition string_list_hid (lt: list_term): ?? pstring := + DO id <~ string_of_hashcode (list_term_get_hid lt);; + RET ("L" +; (CamlStr id)). + +Definition print_raw_term (t: term): ?? unit := + match t with + | Input x _ => + DO s <~ string_of_name x;; + println( "init_access " +; s) + | App o (LTnil _) _ => + DO so <~ string_of_op o;; + println so + | App o l _ => + DO so <~ string_of_op o;; + DO sl <~ string_list_hid l;; + println (so +; " " +; sl) + end. + +(* +Definition print_raw_list(lt: list_term): ?? unit := + match lt with + | LTnil _=> println "" + | LTcons t l _ => + DO st <~ string_term_hid t;; + DO sl <~ string_list_hid l;; + println(st +; " " +; sl) + end. +*) + +Section PrettryPrint. + +Variable get_debug_info: term -> ?? option pstring. + +Fixpoint string_of_term (t: term): ?? pstring := + match t with + | Input x _ => string_of_name x + | App o (LTnil _) _ => string_of_op o + | App o l _ => + DO so <~ string_of_op o;; + DO sl <~ string_of_list_term l;; + RET (so +; "[" +; sl +; "]") + end +with string_of_list_term (l: list_term): ?? pstring := + match l with + | LTnil _ => RET (Str "") + | LTcons t (LTnil _) _ => + DO dbg <~ get_debug_info t;; + match dbg with + | Some x => RET x + | None => string_of_term t + end + | LTcons t l' _ => + DO st <~ (DO dbg <~ get_debug_info t;; + match dbg with + | Some x => RET x + | None => string_of_term t + end);; + DO sl <~ string_of_list_term l';; + RET (st +; ";" +; sl) + end. + + +End PrettryPrint. + + +Definition pretty_term gdi t := + DO r <~ string_of_term gdi t;; + println(r). + +Fixpoint print_head (head: list pstring): ?? unit := + match head with + | i::head' => println (i);; print_head head' + | _ => RET tt + end. + +Definition print_term gdi (head: list pstring) (t: term): ?? unit := + print_head head;; + DO s <~ string_term_hid t;; + print (s +; ": ");; + print_raw_term t;; + DO dbg <~ gdi t;; + match dbg with + | Some x => + print("// " +; x +; " <- ");; + pretty_term gdi t + | None => RET tt + end. + +Definition print_list gdi (head: list pstring) (lt: list_term): ?? unit := + print_head head;; + DO s <~ string_list_hid lt ;; + print (s +; ": ");; + (* print_raw_list lt;; *) + DO ps <~ string_of_list_term gdi lt;; + println("[" +; ps +; "]"). + + +Definition print_tables gdi ext exl: ?? unit := + println "-- term table --" ;; + iterall ext (fun head _ pt => print_term gdi head pt.(hdata));; + println "-- list table --" ;; + iterall exl (fun head _ pl => print_list gdi head pl.(hdata));; + println "----------------". + +Definition print_final_debug gdi (d1 d2: hsmem): ?? unit + := DO b <~ Dict.not_eq_witness d1 d2 ;; + match b with + | Some x => + DO s <~ string_of_name x;; + println("mismatch on: " +; s);; + match Dict.get d1 x with + | None => println("=> unassigned in 1st bblock") + | Some t1 => + print("=> node expected from 1st bblock: ");; + pretty_term gdi t1 + end;; + match Dict.get d2 x with + | None => println("=> unassigned in 2nd bblock") + | Some t2 => + print("=> node found from 2nd bblock: ");; + pretty_term gdi t2 + end + | None => FAILWITH "bug in Dict.not_eq_witness ?" + end. + +Definition witness:= option term. + +Definition msg_term (cr: cref witness) t := + set cr (Some t);; + RET msg_unknow_term. + +Definition print_witness gdi cr (*msg*) := + DO wit <~ get cr ();; + match wit with + | Some t => + println("=> unknown term node: ");; + pretty_term gdi t (*;; + println("=> encoded on " +; msg +; " graph as: ");; + print_raw_term t *) + | None => println "Unexpected failure: no witness info (hint: hash-consing bug ?)" + end. + + +Definition print_error_end1 gdi hct hcl (d1 d2:hsmem): ?? unit + := println "- GRAPH of 1st bblock";; + DO ext <~ export hct ();; + DO exl <~ export hcl ();; + print_tables gdi ext exl;; + print_error_end d1 d2;; + print_final_debug gdi d1 d2. + +Definition print_error1 gdi hct hcl cr log s : ?? unit + := println "- GRAPH of 1st bblock";; + DO ext <~ export hct ();; + DO exl <~ export hcl ();; + print_tables gdi ext exl;; + print_error log s;; + print_witness gdi cr (*"1st"*). + + +Definition xmsg_number: pstring := "on 1st bblock -- on inst num ". + +Definition print_error_end2 gdi hct hcl (d1 d2:hsmem): ?? unit + := println (msg_prefix +; msg_error_on_end);; + println "- GRAPH of 2nd bblock";; + DO ext <~ export hct ();; + DO exl <~ export hcl ();; + print_tables gdi ext exl. + +Definition print_error2 gdi hct hcl cr (log: logger unit) (s:pstring): ?? unit + := DO n <~ log_info log ();; + DO ext <~ export hct ();; + DO exl <~ export hcl ();; + println (msg_prefix +; xmsg_number +; n +; " -- " +; s);; + print_witness gdi cr (*"2nd"*);; + println "- GRAPH of 2nd bblock";; + print_tables gdi ext exl. + +(* USELESS +Definition simple_log_assign (d: D.t term pstring) (x: R.t) (t: term): ?? unit := + DO s <~ string_of_name x;; + d.(D.set) (t,s). +*) + +Definition log_assign (d: D.t term pstring) (log: logger unit) (x: R.t) (t: term): ?? unit := + DO i <~ log_info log ();; + DO sx <~ string_of_name x;; + d.(D.set) (t,(sx +; "@" +; i)). + +Definition msg_new_inst : pstring := "--- inst ". + +Definition hlog (log: logger unit) (hct: hashConsing term) (hcl: hashConsing list_term): unit -> ?? unit := + (fun _ => + log_insert log tt ;; + DO s <~ log_info log tt;; + let s:= msg_new_inst +; s in + next_log hct s;; + next_log hcl s + ). + +Program Definition verb_bblock_simu_test (p1 p2: bblock): ?? bool := + DO dict_info <~ make_dict (mk_hash_params (fun _ => RET tt));; + DO log1 <~ count_logger ();; + DO log2 <~ count_logger ();; + DO cr <~ make_cref None;; + DO hco_term <~ mk_annot (hCons hpt);; + DO hco_list <~ mk_annot (hCons hplt);; + DO result1 <~ g_bblock_simu_test + (log_assign dict_info log1) + (log_new_term (msg_term cr)) + (hlog log1 hco_term hco_list) + (log_insert log2) + hco_term _ + hco_list _ + (print_error_end1 dict_info.(D.get) hco_term hco_list) + (print_error1 dict_info.(D.get) hco_term hco_list cr log2) + true + failpreserv_error + p1 p2;; + if result1 + then RET true + else + DO dict_info <~ make_dict (mk_hash_params (fun _ => RET tt));; + DO log1 <~ count_logger ();; + DO log2 <~ count_logger ();; + DO cr <~ make_cref None;; + DO hco_term <~ mk_annot (hCons hpt);; + DO hco_list <~ mk_annot (hCons hplt);; + DO result2 <~ g_bblock_simu_test + (log_assign dict_info log1) + (*fun _ _ => RET no_log_new_term*) (* REM: too weak !! *) + (log_new_term (msg_term cr)) (* REM: too strong ?? *) + (hlog log1 hco_term hco_list) + (log_insert log2) + hco_term _ + hco_list _ + (print_error_end2 dict_info.(D.get) hco_term hco_list) + (print_error2 dict_info.(D.get) hco_term hco_list cr log2) + false + (fun _ => RET tt) + p2 p1;; + if result2 + then ( + println (msg_prefix +; " OOops - symmetry violation in bblock_simu_test => this is a bug of bblock_simu_test ??");; + RET false + ) else RET false + . +Obligation 1. + generalize (hCons_correct _ _ _ H0); clear H0. + wlp_simplify. +Qed. +Obligation 2. + generalize (hCons_correct _ _ _ H); clear H. + wlp_simplify. +Qed. +Obligation 3. + generalize (hCons_correct _ _ _ H0); clear H0. + wlp_simplify. +Qed. +Obligation 4. + generalize (hCons_correct _ _ _ H); clear H. + wlp_simplify. +Qed. + +Theorem verb_bblock_simu_test_correct p1 p2: + WHEN verb_bblock_simu_test p1 p2 ~> b THEN b=true -> forall ge, bblock_simu ge p1 p2. +Proof. + wlp_simplify. +Qed. +Global Opaque verb_bblock_simu_test. + +End Verbose_version. + +End SimuWithReduce. + +(* TODO: why inlining fails here ? *) +Transparent hterm_lift. +Extraction Inline lift. + +End ImpSimu. + +Require Import FMapPositive. + + +Require Import PArith. +Require Import FMapPositive. + +Module ImpPosDict <: ImpDict with Module R:=Pos. + +Module R:=Pos. + +Definition t:=PositiveMap.t. + +Definition get {A} (d:t A) (x:R.t): option A + := PositiveMap.find x d. + +Definition set {A} (d:t A) (x:R.t) (v:A): t A + := PositiveMap.add x v d. + +Local Hint Unfold PositiveMap.E.eq: core. + +Lemma set_spec_eq A d x (v: A): + get (set d x v) x = Some v. +Proof. + unfold get, set; apply PositiveMap.add_1; auto. +Qed. + +Lemma set_spec_diff A d x y (v: A): + x <> y -> get (set d x v) y = get d y. +Proof. + unfold get, set; intros; apply PositiveMap.gso; auto. +Qed. + +Definition rem {A} (d:t A) (x:R.t): t A + := PositiveMap.remove x d. + +Lemma rem_spec_eq A (d: t A) x: + get (rem d x) x = None. +Proof. + unfold get, rem; apply PositiveMap.grs; auto. +Qed. + +Lemma rem_spec_diff A (d: t A) x y: + x <> y -> get (rem d x) y = get d y. +Proof. + unfold get, rem; intros; apply PositiveMap.gro; auto. +Qed. + + +Definition empty {A}: t A := PositiveMap.empty A. + +Lemma empty_spec A x: + get (empty (A:=A)) x = None. +Proof. + unfold get, empty; apply PositiveMap.gempty; auto. +Qed. + +Import PositiveMap. + +Fixpoint eq_test {A} (d1 d2: t A): ?? bool := + match d1, d2 with + | Leaf _, Leaf _ => RET true + | Node l1 (Some x1) r1, Node l2 (Some x2) r2 => + DO b0 <~ phys_eq x1 x2 ;; + if b0 then + DO b1 <~ eq_test l1 l2 ;; + if b1 then + eq_test r1 r2 + else + RET false + else + RET false + | Node l1 None r1, Node l2 None r2 => + DO b1 <~ eq_test l1 l2 ;; + if b1 then + eq_test r1 r2 + else + RET false + | _, _ => RET false + end. + +Lemma eq_test_correct A d1: forall (d2: t A), + WHEN eq_test d1 d2 ~> b THEN + b=true -> forall x, get d1 x = get d2 x. +Proof. + unfold get; induction d1 as [|l1 Hl1 [x1|] r1 Hr1]; destruct d2 as [|l2 [x2|] r2]; simpl; + wlp_simplify; (discriminate || (subst; destruct x; simpl; auto)). +Qed. +Global Opaque eq_test. + +(* ONLY FOR DEBUGGING INFO: get some key of a non-empty d *) +Fixpoint pick {A} (d: t A): ?? R.t := + match d with + | Leaf _ => FAILWITH "unexpected empty dictionary" + | Node _ (Some _) _ => RET xH + | Node (Leaf _) None r => + DO p <~ pick r;; + RET (xI p) + | Node l None _ => + DO p <~ pick l;; + RET (xO p) + end. + +(* ONLY FOR DEBUGGING INFO: find one variable on which d1 and d2 differs *) +Fixpoint not_eq_witness {A} (d1 d2: t A): ?? option R.t := + match d1, d2 with + | Leaf _, Leaf _ => RET None + | Node l1 (Some x1) r1, Node l2 (Some x2) r2 => + DO b0 <~ phys_eq x1 x2 ;; + if b0 then + DO b1 <~ not_eq_witness l1 l2;; + match b1 with + | None => + DO b2 <~ not_eq_witness r1 r2;; + match b2 with + | None => RET None + | Some p => RET (Some (xI p)) + end + | Some p => RET (Some (xO p)) + end + else + RET (Some xH) + | Node l1 None r1, Node l2 None r2 => + DO b1 <~ not_eq_witness l1 l2;; + match b1 with + | None => + DO b2 <~ not_eq_witness r1 r2;; + match b2 with + | None => RET None + | Some p => RET (Some (xI p)) + end + | Some p => RET (Some (xO p)) + end + | l, Leaf _ => DO p <~ pick l;; RET (Some p) + | Leaf _, r => DO p <~ pick r;; RET (Some p) + | _, _ => RET (Some xH) + end. + +End ImpPosDict. + diff --git a/mppa_k1c/abstractbb/Impure/ImpConfig.v b/mppa_k1c/abstractbb/Impure/ImpConfig.v index 1bd93d4c..e49a4611 100644 --- a/mppa_k1c/abstractbb/Impure/ImpConfig.v +++ b/mppa_k1c/abstractbb/Impure/ImpConfig.v @@ -22,9 +22,9 @@ Module Type ImpureView. (* START COMMENT *) Module UnsafeImpure. - Parameter unsafe_coerce: forall {A}, t A -> A. + Parameter unsafe_coerce: forall {A}, t A -> option A. - Parameter unsafe_coerce_not_really_correct: forall A (k: t A) (x:A), (unsafe_coerce k)=x -> mayRet k x. + Parameter unsafe_coerce_not_really_correct: forall A (k: t A) (x:A), (unsafe_coerce k)=Some x -> mayRet k x. Extraction Inline unsafe_coerce. @@ -41,11 +41,11 @@ Module Impure: ImpureView. Module UnsafeImpure. - Definition unsafe_coerce {A} (x:t A) := x. + Definition unsafe_coerce {A} (x:t A) := Some x. - Lemma unsafe_coerce_not_really_correct: forall A (k: t A) x, (unsafe_coerce k)=x -> mayRet k x. + Lemma unsafe_coerce_not_really_correct: forall A (k: t A) x, (unsafe_coerce k)=Some x -> mayRet k x. Proof. - unfold unsafe_coerce, mayRet; auto. + unfold unsafe_coerce, mayRet; congruence. Qed. End UnsafeImpure. diff --git a/mppa_k1c/abstractbb/Impure/ImpCore.v b/mppa_k1c/abstractbb/Impure/ImpCore.v index 7925f62d..f1abaf7a 100644 --- a/mppa_k1c/abstractbb/Impure/ImpCore.v +++ b/mppa_k1c/abstractbb/Impure/ImpCore.v @@ -193,4 +193,4 @@ Ltac wlp_xsimplify hint := Create HintDb wlp discriminated. -Ltac wlp_simplify := wlp_xsimplify ltac:(intuition (eauto with wlp)).
\ No newline at end of file +Ltac wlp_simplify := wlp_xsimplify ltac:(intuition eauto with wlp).
\ No newline at end of file diff --git a/mppa_k1c/abstractbb/Impure/ImpHCons.v b/mppa_k1c/abstractbb/Impure/ImpHCons.v index dd615628..637116cc 100644 --- a/mppa_k1c/abstractbb/Impure/ImpHCons.v +++ b/mppa_k1c/abstractbb/Impure/ImpHCons.v @@ -95,45 +95,105 @@ Proof. wlp_simplify. Qed. Global Opaque assert_list_incl. -Hint Resolve assert_list_incl_correct. +Hint Resolve assert_list_incl_correct: wlp. End Sets. + + + (********************************) (* (Weak) HConsing *) +Module HConsing. -Axiom xhCons: forall {A}, ((A -> A -> ?? bool) * (pre_hashV A -> ?? hashV A)) -> ?? hashConsing A. +Export HConsingDefs. + +(* NB: this axiom is NOT intended to be called directly, but only through [hCons...] functions below. *) +Axiom xhCons: forall {A}, (hashP A) -> ?? hashConsing A. Extract Constant xhCons => "ImpHConsOracles.xhCons". -Definition hCons_eq_msg: pstring := "xhCons: hash_eq differs". +Definition hCons_eq_msg: pstring := "xhCons: hash eq differs". -Definition hCons {A} (hash_eq: A -> A -> ?? bool) (unknownHash_msg: pre_hashV A -> ?? pstring): ?? (hashConsing A) := - DO hco <~ xhCons (hash_eq, fun v => DO s <~ unknownHash_msg v ;; FAILWITH s) ;; +Definition hCons {A} (hp: hashP A): ?? (hashConsing A) := + DO hco <~ xhCons hp ;; RET {| - hC := fun x => - DO x' <~ hC hco x ;; - DO b0 <~ hash_eq (pre_data x) (data x') ;; - assert_b b0 hCons_eq_msg;; - RET x'; - hC_known := fun x => - DO x' <~ hC_known hco x ;; - DO b0 <~ hash_eq (pre_data x) (data x') ;; - assert_b b0 hCons_eq_msg;; - RET x'; - next_log := next_log hco; - export := export hco; + hC := (fun x => + DO x' <~ hC hco x ;; + DO b0 <~ hash_eq hp x.(hdata) x' ;; + assert_b b0 hCons_eq_msg;; + RET x'); + next_hid := hco.(next_hid); + next_log := hco.(next_log); + export := hco.(export); + remove := hco.(remove) |}. -Lemma hCons_correct: forall A (hash_eq: A -> A -> ?? bool) msg, - WHEN hCons hash_eq msg ~> hco THEN - ((forall x y, WHEN hash_eq x y ~> b THEN b=true -> x=y) -> forall x, WHEN hC hco x ~> x' THEN (pre_data x)=(data x')) - /\ ((forall x y, WHEN hash_eq x y ~> b THEN b=true -> x=y) -> forall x, WHEN hC_known hco x ~> x' THEN (pre_data x)=(data x')). + +Lemma hCons_correct A (hp: hashP A): + WHEN hCons hp ~> hco THEN + (forall x y, WHEN hp.(hash_eq) x y ~> b THEN b=true -> (ignore_hid hp x)=(ignore_hid hp y)) -> + forall x, WHEN hco.(hC) x ~> x' THEN ignore_hid hp x.(hdata)=ignore_hid hp x'. Proof. wlp_simplify. Qed. Global Opaque hCons. Hint Resolve hCons_correct: wlp. -Definition hCons_spec {A} (hco: hashConsing A) := - (forall x, WHEN hC hco x ~> x' THEN (pre_data x)=(data x')) /\ (forall x, WHEN hC_known hco x ~> x' THEN (pre_data x)=(data x')). + + +(* hashV: extending a given type with hash-consing *) +Record hashV {A:Type}:= { + data: A; + hid: hashcode +}. +Arguments hashV: clear implicits. + +Definition hashV_C {A} (test_eq: A -> A -> ?? bool) : hashP (hashV A) := {| + hash_eq := fun v1 v2 => test_eq v1.(data) v2.(data); + get_hid := hid; + set_hid := fun v id => {| data := v.(data); hid := id |} +|}. + +Definition liftHV (x:nat) := {| data := x; hid := unknown_hid |}. + +Definition hConsV {A} (hasheq: A -> A -> ?? bool): ?? (hashConsing (hashV A)) := + hCons (hashV_C hasheq). + +Lemma hConsV_correct A (hasheq: A -> A -> ?? bool): + WHEN hConsV hasheq ~> hco THEN + (forall x y, WHEN hasheq x y ~> b THEN b=true -> x=y) -> + forall x, WHEN hco.(hC) x ~> x' THEN x.(hdata).(data)=x'.(data). +Proof. + Local Hint Resolve f_equal2: core. + wlp_simplify. + exploit H; eauto. + + wlp_simplify. + + intros; congruence. +Qed. +Global Opaque hConsV. +Hint Resolve hConsV_correct: wlp. + +Definition hC_known {A} (hco:hashConsing (hashV A)) (unknownHash_msg: hashinfo (hashV A) -> ?? pstring) (x:hashinfo (hashV A)): ?? hashV A := + DO clock <~ hco.(next_hid)();; + DO x' <~ hco.(hC) x;; + DO ok <~ hash_older x'.(hid) clock;; + if ok + then RET x' + else + hco.(remove) x;; + DO msg <~ unknownHash_msg x;; + FAILWITH msg. + +Lemma hC_known_correct A (hco:hashConsing (hashV A)) msg x: + WHEN hC_known hco msg x ~> x' THEN + (forall x, WHEN hco.(hC) x ~> x' THEN x.(hdata).(data)=x'.(data)) -> + x.(hdata).(data)=x'.(data). +Proof. + wlp_simplify. + unfold wlp in * |- ; eauto. +Qed. +Global Opaque hC_known. +Hint Resolve hC_known_correct: wlp. + +End HConsing. diff --git a/mppa_k1c/abstractbb/Impure/ImpLoops.v b/mppa_k1c/abstractbb/Impure/ImpLoops.v index dc8b2627..33376c19 100644 --- a/mppa_k1c/abstractbb/Impure/ImpLoops.v +++ b/mppa_k1c/abstractbb/Impure/ImpLoops.v @@ -17,7 +17,7 @@ Section While_Loop. (** Local Definition of "while-loop-invariant" *) Let wli {S} cond body (I: S -> Prop) := forall s, I s -> cond s = true -> WHEN (body s) ~> s' THEN I s'. -Program Definition while {S} cond body (I: S -> Prop | wli cond body I) s0: ?? {s | I s0 -> I s /\ cond s = false} +Program Definition while {S} cond body (I: S -> Prop | wli cond body I) s0: ?? {s | (I s0 -> I s) /\ cond s = false} := loop (A:={s | I s0 -> I s}) (s0, fun s => @@ -26,7 +26,7 @@ Program Definition while {S} cond body (I: S -> Prop | wli cond body I) s0: ?? { DO s' <~ mk_annot (body s) ;; RET (inl (A:={s | I s0 -> I s }) s') | false => - RET (inr (B:={s | I s0 -> I s /\ cond s = false}) s) + RET (inr (B:={s | (I s0 -> I s) /\ cond s = false}) s) end). Obligation 2. unfold wli, wlp in * |-; eauto. @@ -83,7 +83,7 @@ Definition wapply {A B} {R: A -> B -> Prop} (beq: A -> A -> ?? bool) (k: A -> ?? assert_b b msg;; RET (output a). -Lemma wapply_correct A B (R: A -> B -> Prop) (beq: A -> A -> ?? bool)x (k: A -> ?? answ R): +Lemma wapply_correct A B (R: A -> B -> Prop) (beq: A -> A -> ?? bool) (k: A -> ?? answ R) x: beq_correct beq -> WHEN wapply beq k x ~> y THEN R x y. Proof. @@ -107,7 +107,7 @@ Definition rec_preserv {A B} (recF: (A -> ?? B) -> A -> ?? B) (R: A -> B -> Prop Program Definition rec {A B} beq recF (R: A -> B -> Prop) (H1: rec_preserv recF R) (H2: beq_correct beq): ?? (A -> ?? B) := DO f <~ xrec (B:=answ R) (fun f x => DO y <~ mk_annot (recF (wapply beq f) x) ;; - RET {| input := x; output := proj1_sig y |});; + RET {| input := x; output := `y |});; RET (wapply beq f). Obligation 1. eapply H1; eauto. clear H H1. diff --git a/mppa_k1c/abstractbb/Impure/ImpPrelude.v b/mppa_k1c/abstractbb/Impure/ImpPrelude.v index 1a84eb3b..de4c7973 100644 --- a/mppa_k1c/abstractbb/Impure/ImpPrelude.v +++ b/mppa_k1c/abstractbb/Impure/ImpPrelude.v @@ -91,11 +91,17 @@ Extract Inlined Constant struct_eq => "(=)". Hint Resolve struct_eq_correct: wlp. -(** Data-structure for generic hash-consing, hash-set *) +(** Data-structure for generic hash-consing *) Axiom hashcode: Type. Extract Constant hashcode => "int". +(* NB: hashConsing is assumed to generate hash-code in ascending order. + This gives a way to check that a hash-consed value is older than an other one. +*) +Axiom hash_older: hashcode -> hashcode -> ?? bool. +Extract Inlined Constant hash_older => "(<)". + Module Dict. Record hash_params {A:Type} := { @@ -115,42 +121,45 @@ Arguments t: clear implicits. End Dict. +Module HConsingDefs. -(* NB: hashConsing is assumed to generate hash-code in ascending order. - This gives a way to check that a hash-consed value is older than an other one. -*) -Axiom hash_older: hashcode -> hashcode -> ?? bool. -Extract Inlined Constant hash_older => "(<=)". - -Record pre_hashV {A: Type} := { - pre_data: A; +Record hashinfo {A: Type} := { + hdata: A; hcodes: list hashcode; - debug_info: option pstring; }. -Arguments pre_hashV: clear implicits. +Arguments hashinfo: clear implicits. -Record hashV {A:Type}:= { - data: A; - hid: hashcode +(* for inductive types with intrinsic hash-consing *) +Record hashP {A:Type}:= { + hash_eq: A -> A -> ?? bool; + get_hid: A -> hashcode; + set_hid: A -> hashcode -> A; (* WARNING: should only be used by hash-consing machinery *) }. -Arguments hashV: clear implicits. +Arguments hashP: clear implicits. + +Axiom unknown_hid: hashcode. +Extract Constant unknown_hid => "-1". + +Definition ignore_hid {A} (hp: hashP A) (hv:A) := set_hid hp hv unknown_hid. Record hashExport {A:Type}:= { - get_hashV: hashcode -> ?? pre_hashV A; - iterall: ((list pstring) -> hashcode -> pre_hashV A -> ?? unit) -> ?? unit; (* iter on all elements in the hashtbl, by order of creation *) + get_info: hashcode -> ?? hashinfo A; + iterall: ((list pstring) -> hashcode -> hashinfo A -> ?? unit) -> ?? unit; (* iter on all elements in the hashtbl, by order of creation *) }. Arguments hashExport: clear implicits. Record hashConsing {A:Type}:= { - (* TODO next_hashcode: unit -> ?? hashcode *) - hC: pre_hashV A -> ?? hashV A; - hC_known: pre_hashV A -> ?? hashV A; (* fails on unknown inputs *) - (**** below: debugging functions ****) + hC: hashinfo A -> ?? A; + (**** below: debugging or internal functions ****) + next_hid: unit -> ?? hashcode; (* should be strictly less old than ignore_hid *) + remove: hashinfo A -> ??unit; (* SHOULD NOT BE USED ! *) next_log: pstring -> ?? unit; (* insert a log info (for the next introduced element) -- regiven by [iterall export] below *) export: unit -> ?? hashExport A ; }. Arguments hashConsing: clear implicits. +End HConsingDefs. + (** recMode: this is mainly for Tests ! *) Inductive recMode:= StdRec | MemoRec | BareRec | BuggyRec. diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml index b7a80679..2b66899b 100644 --- a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml +++ b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml @@ -1,6 +1,5 @@ open ImpPrelude - -exception Stop;; +open HConsingDefs let make_dict (type key) (p: key Dict.hash_params) = let module MyHashedType = struct @@ -16,10 +15,15 @@ let make_dict (type key) (p: key Dict.hash_params) = } -let xhCons (type a) (hash_eq, error: (a -> a -> bool)*(a pre_hashV -> a hashV)) = +exception Stop;; + +let xhCons (type a) (hp:a hashP) = + (* We use a hash-table, but a hash-set would be sufficient ! *) + (* Thus, we could use a weak hash-set, but prefer avoid it for easier debugging *) + (* Ideally, a parameter would allow to select between the weak or full version *) let module MyHashedType = struct - type t = a pre_hashV - let equal x y = hash_eq x.pre_data y.pre_data + type t = a hashinfo + let equal x y = hp.hash_eq x.hdata y.hdata let hash x = Hashtbl.hash x.hcodes end in let module MyHashtbl = Hashtbl.Make(MyHashedType) in @@ -34,21 +38,18 @@ let xhCons (type a) (hash_eq, error: (a -> a -> bool)*(a pre_hashV -> a hashV)) let t = MyHashtbl.create 1000 in let logs = ref [] in { - hC = (fun (x:a pre_hashV) -> - match MyHashtbl.find_opt t x with - | Some x' -> x' + hC = (fun (k:a hashinfo) -> + match MyHashtbl.find_opt t k with + | Some d -> d | None -> (*print_string "+";*) - let x' = { data = x.pre_data ; - hid = MyHashtbl.length t } - in MyHashtbl.add t x x'; x'); - hC_known = (fun (x:a pre_hashV) -> - match MyHashtbl.find_opt t x with - | Some x' -> x' - | None -> error x); + let d = hp.set_hid k.hdata (MyHashtbl.length t) in + MyHashtbl.add t {k with hdata = d } d; d); next_log = (fun info -> logs := (MyHashtbl.length t, info)::(!logs)); + next_hid = (fun () -> MyHashtbl.length t); + remove = (fun (x:a hashinfo) -> MyHashtbl.remove t x); export = fun () -> match pick t with - | None -> { get_hashV = (fun _ -> raise Not_found); iterall = (fun _ -> ()) } + | None -> { get_info = (fun _ -> raise Not_found); iterall = (fun _ -> ()) } | Some (k,_) -> (* the state is fully copied at export ! *) let logs = ref (List.rev_append (!logs) []) in @@ -57,9 +58,9 @@ let xhCons (type a) (hash_eq, error: (a -> a -> bool)*(a pre_hashV -> a hashV)) | (j, info)::l' when i>=j -> logs:=l'; info::(step_log i) | _ -> [] in let a = Array.make (MyHashtbl.length t) k in - MyHashtbl.iter (fun k d -> a.(d.hid) <- k) t; + MyHashtbl.iter (fun k d -> a.(hp.get_hid d) <- k) t; { - get_hashV = (fun i -> a.(i)); + get_info = (fun i -> a.(i)); iterall = (fun iter_node -> Array.iteri (fun i k -> iter_node (step_log i) i k) a) } } diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli index a74c721a..5075d176 100644 --- a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli +++ b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli @@ -1,4 +1,5 @@ open ImpPrelude +open HConsingDefs -val make_dict : 'a1 Dict.hash_params -> ('a1, 'a2) Dict.t -val xhCons: (('a -> 'a -> bool) * ('a pre_hashV -> 'a hashV)) -> 'a hashConsing +val make_dict : 'a Dict.hash_params -> ('a, 'b) Dict.t +val xhCons: 'a hashP -> 'a hashConsing diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml b/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml index 33c3c842..9e63c12d 100644 --- a/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml +++ b/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml @@ -74,7 +74,7 @@ let println: pstring -> unit = fun l -> print l; print_newline() let read_line () = - CamlStr (Pervasives.read_line());; + CamlStr (Stdlib.read_line());; exception ImpureFail of pstring;; diff --git a/mppa_k1c/abstractbb/Parallelizability.v b/mppa_k1c/abstractbb/Parallelizability.v index d1971e57..30904b5d 100644 --- a/mppa_k1c/abstractbb/Parallelizability.v +++ b/mppa_k1c/abstractbb/Parallelizability.v @@ -1,4 +1,4 @@ -(** Parallel Semantics of Abstract Basic Blocks and parallelizability test.s +(** Parallel Semantics of Abstract Basic Blocks and parallelizability test. *) Require Setoid. (* in order to rewrite <-> *) @@ -32,7 +32,7 @@ Fixpoint inst_prun (i: inst) (m tmp old: mem): option mem := end end. -(* [inst_prun] is generalization of [inst_run] *) +(* [inst_prun] is generalization of [inst_run] *) Lemma inst_run_prun i: forall m old, inst_run ge i m old = inst_prun i m m old. Proof. @@ -332,7 +332,7 @@ Fixpoint bblock_wframe(p:bblock): list R.t := | i::p' => (inst_wframe i)++(bblock_wframe p') end. -Local Hint Resolve Permutation_app_head Permutation_app_tail Permutation_app_comm. +Local Hint Resolve Permutation_app_head Permutation_app_tail Permutation_app_comm: core. Lemma bblock_wframe_Permutation p p': Permutation p p' -> Permutation (bblock_wframe p) (bblock_wframe p'). @@ -620,7 +620,7 @@ Include ParallelizablityChecking L. Section PARALLEL2. Variable ge: genv. -Local Hint Resolve S.empty_match_frame S.add_match_frame S.union_match_frame S.is_disjoint_match_frame. +Local Hint Resolve S.empty_match_frame S.add_match_frame S.union_match_frame S.is_disjoint_match_frame: core. (** Now, refinement of each operation toward parallelizable *) @@ -659,14 +659,14 @@ Fixpoint inst_sframe (i: inst): S.t := | a::i' => S.add (fst a) (S.union (exp_sframe (snd a)) (inst_sframe i')) end. -Local Hint Resolve exp_sframe_correct. +Local Hint Resolve exp_sframe_correct: core. Lemma inst_sframe_correct i: S.match_frame (inst_sframe i) (inst_frame i). Proof. induction i as [|[y e] i']; simpl; auto. Qed. -Local Hint Resolve inst_wsframe_correct inst_sframe_correct. +Local Hint Resolve inst_wsframe_correct inst_sframe_correct: core. Fixpoint is_pararec (p: bblock) (wsframe: S.t): bool := match p with diff --git a/mppa_k1c/abstractbb/SeqSimuTheory.v b/mppa_k1c/abstractbb/SeqSimuTheory.v new file mode 100644 index 00000000..e234883f --- /dev/null +++ b/mppa_k1c/abstractbb/SeqSimuTheory.v @@ -0,0 +1,384 @@ +(** A theory for checking/proving simulation by symbolic execution. + +*) + + +Require Coq.Logic.FunctionalExtensionality. (* not really necessary -- see lemma at the end *) +Require Setoid. (* in order to rewrite <-> *) +Require Export AbstractBasicBlocksDef. +Require Import List. +Require Import ImpPrelude. +Import HConsingDefs. + + +Module SimuTheory (L: SeqLanguage). + +Export L. +Export LP. + +Inductive term := + | Input (x:R.t) + | App (o: op) (l: list_term) +with list_term := + | LTnil + | LTcons (t:term) (l:list_term) + . + +Fixpoint term_eval (ge: genv) (t: term) (m: mem): option value := + match t with + | Input x => Some (m x) + | App o l => + match list_term_eval ge l m with + | Some v => op_eval ge o v + | _ => None + end + end +with list_term_eval ge (l: list_term) (m: mem) {struct l}: option (list value) := + match l with + | LTnil => Some nil + | LTcons t l' => + match term_eval ge t m, list_term_eval ge l' m with + | Some v, Some lv => Some (v::lv) + | _, _ => None + end + end. + +(* the symbolic memory: + - pre: pre-condition expressing that the computation has not yet abort on a None. + - post: the post-condition for each pseudo-register +*) +Record smem:= {pre: genv -> mem -> Prop; post:> R.t -> term}. + +(** initial symbolic memory *) +Definition smem_empty := {| pre:=fun _ _ => True; post:=(fun x => Input x) |}. + +Fixpoint exp_term (e: exp) (d old: smem) : term := + match e with + | PReg x => d x + | Op o le => App o (list_exp_term le d old) + | Old e => exp_term e old old + end +with list_exp_term (le: list_exp) (d old: smem) : list_term := + match le with + | Enil => LTnil + | Econs e le' => LTcons (exp_term e d old) (list_exp_term le' d old) + | LOld le => list_exp_term le old old + end. + + +(** assignment of the symbolic memory *) +Definition smem_set (d:smem) x (t:term) := + {| pre:=(fun ge m => (term_eval ge (d x) m) <> None /\ (d.(pre) ge m)); + post:=fun y => if R.eq_dec x y then t else d y |}. + +Section SIMU_THEORY. + +Variable ge: genv. + +Lemma set_spec_eq d x t m: + term_eval ge (smem_set d x t x) m = term_eval ge t m. +Proof. + unfold smem_set; simpl; case (R.eq_dec x x); try congruence. +Qed. + +Lemma set_spec_diff d x y t m: + x <> y -> term_eval ge (smem_set d x t y) m = term_eval ge (d y) m. +Proof. + unfold smem_set; simpl; case (R.eq_dec x y); try congruence. +Qed. + +Fixpoint inst_smem (i: inst) (d old: smem): smem := + match i with + | nil => d + | (x, e)::i' => + let t:=exp_term e d old in + inst_smem i' (smem_set d x t) old + end. + +Fixpoint bblock_smem_rec (p: bblock) (d: smem): smem := + match p with + | nil => d + | i::p' => + let d':=inst_smem i d d in + bblock_smem_rec p' d' + end. + +Definition bblock_smem: bblock -> smem + := fun p => bblock_smem_rec p smem_empty. + +Lemma inst_smem_pre_monotonic i old: forall d m, + (pre (inst_smem i d old) ge m) -> (pre d ge m). +Proof. + induction i as [|[y e] i IHi]; simpl; auto. + intros d a H; generalize (IHi _ _ H); clear H IHi. + unfold smem_set; simpl; intuition. +Qed. + +Lemma bblock_smem_pre_monotonic p: forall d m, + (pre (bblock_smem_rec p d) ge m) -> (pre d ge m). +Proof. + induction p as [|i p' IHp']; simpl; eauto. + intros d a H; eapply inst_smem_pre_monotonic; eauto. +Qed. + +Local Hint Resolve inst_smem_pre_monotonic bblock_smem_pre_monotonic: core. + +Lemma term_eval_exp e (od:smem) m0 old: + (forall x, term_eval ge (od x) m0 = Some (old x)) -> + forall (d:smem) m1, + (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> + term_eval ge (exp_term e d od) m0 = exp_eval ge e m1 old. +Proof. + intro H. + induction e using exp_mut with + (P0:=fun l => forall (d:smem) m1, (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> list_term_eval ge (list_exp_term l d od) m0 = list_exp_eval ge l m1 old); + simpl; auto. + - intros; erewrite IHe; eauto. + - intros. erewrite IHe, IHe0; eauto. +Qed. + +Lemma inst_smem_abort i m0 x old: forall (d:smem), + pre (inst_smem i d old) ge m0 -> + term_eval ge (d x) m0 = None -> + term_eval ge (inst_smem i d old x) m0 = None. +Proof. + induction i as [|[y e] i IHi]; simpl; auto. + intros d VALID H; erewrite IHi; eauto. clear IHi. + unfold smem_set; simpl; destruct (R.eq_dec y x); auto. + subst; + generalize (inst_smem_pre_monotonic _ _ _ _ VALID); clear VALID. + unfold smem_set; simpl. intuition congruence. +Qed. + +Lemma block_smem_rec_abort p m0 x: forall d, + pre (bblock_smem_rec p d) ge m0 -> + term_eval ge (d x) m0 = None -> + term_eval ge (bblock_smem_rec p d x) m0 = None. +Proof. + induction p; simpl; auto. + intros d VALID H; erewrite IHp; eauto. clear IHp. + eapply inst_smem_abort; eauto. +Qed. + +Lemma inst_smem_Some_correct1 i m0 old (od:smem): + (forall x, term_eval ge (od x) m0 = Some (old x)) -> + forall (m1 m2: mem) (d: smem), + inst_run ge i m1 old = Some m2 -> + (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> + forall x, term_eval ge (inst_smem i d od x) m0 = Some (m2 x). +Proof. + intro X; induction i as [|[x e] i IHi]; simpl; intros m1 m2 d H. + - inversion_clear H; eauto. + - intros H0 x0. + destruct (exp_eval ge e m1 old) eqn:Heqov; try congruence. + refine (IHi _ _ _ _ _ _); eauto. + clear x0; intros x0. + unfold assign, smem_set; simpl. destruct (R.eq_dec x x0); auto. + subst; erewrite term_eval_exp; eauto. +Qed. + +Lemma bblocks_smem_rec_Some_correct1 p m0: forall (m1 m2: mem) (d: smem), + run ge p m1 = Some m2 -> + (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> + forall x, term_eval ge (bblock_smem_rec p d x) m0 = Some (m2 x). +Proof. + Local Hint Resolve inst_smem_Some_correct1: core. + induction p as [ | i p]; simpl; intros m1 m2 d H. + - inversion_clear H; eauto. + - intros H0 x0. + destruct (inst_run ge i m1 m1) eqn: Heqov. + + refine (IHp _ _ _ _ _ _); eauto. + + inversion H. +Qed. + +Lemma bblock_smem_Some_correct1 p m0 m1: + run ge p m0 = Some m1 + -> forall x, term_eval ge (bblock_smem p x) m0 = Some (m1 x). +Proof. + intros; eapply bblocks_smem_rec_Some_correct1; eauto. +Qed. + +Lemma inst_smem_None_correct i m0 old (od: smem): + (forall x, term_eval ge (od x) m0 = Some (old x)) -> + forall m1 d, pre (inst_smem i d od) ge m0 -> + (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> + inst_run ge i m1 old = None -> exists x, term_eval ge (inst_smem i d od x) m0 = None. +Proof. + intro X; induction i as [|[x e] i IHi]; simpl; intros m1 d. + - discriminate. + - intros VALID H0. + destruct (exp_eval ge e m1 old) eqn: Heqov. + + refine (IHi _ _ _ _); eauto. + intros x0; unfold assign, smem_set; simpl. destruct (R.eq_dec x x0); auto. + subst; erewrite term_eval_exp; eauto. + + intuition. + constructor 1 with (x:=x); simpl. + apply inst_smem_abort; auto. + rewrite set_spec_eq. + erewrite term_eval_exp; eauto. +Qed. + +Lemma inst_smem_Some_correct2 i m0 old (od: smem): + (forall x, term_eval ge (od x) m0 = Some (old x)) -> + forall (m1 m2: mem) d, + pre (inst_smem i d od) ge m0 -> + (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> + (forall x, term_eval ge (inst_smem i d od x) m0 = Some (m2 x)) -> + res_eq (Some m2) (inst_run ge i m1 old). +Proof. + intro X. + induction i as [|[x e] i IHi]; simpl; intros m1 m2 d VALID H0. + - intros H; eapply ex_intro; intuition eauto. + generalize (H0 x); rewrite H. + congruence. + - intros H. + destruct (exp_eval ge e m1 old) eqn: Heqov. + + refine (IHi _ _ _ _ _ _); eauto. + intros x0; unfold assign, smem_set; simpl; destruct (R.eq_dec x x0); auto. + subst; erewrite term_eval_exp; eauto. + + generalize (H x). + rewrite inst_smem_abort; discriminate || auto. + rewrite set_spec_eq. + erewrite term_eval_exp; eauto. +Qed. + +Lemma bblocks_smem_rec_Some_correct2 p m0: forall (m1 m2: mem) d, + pre (bblock_smem_rec p d) ge m0 -> + (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> + (forall x, term_eval ge (bblock_smem_rec p d x) m0 = Some (m2 x)) -> + res_eq (Some m2) (run ge p m1). +Proof. + induction p as [|i p]; simpl; intros m1 m2 d VALID H0. + - intros H; eapply ex_intro; intuition eauto. + generalize (H0 x); rewrite H. + congruence. + - intros H. + destruct (inst_run ge i m1 m1) eqn: Heqom. + + refine (IHp _ _ _ _ _ _); eauto. + + assert (X: exists x, term_eval ge (inst_smem i d d x) m0 = None). + { eapply inst_smem_None_correct; eauto. } + destruct X as [x H1]. + generalize (H x). + erewrite block_smem_rec_abort; eauto. + congruence. +Qed. + +Lemma bblock_smem_Some_correct2 p m0 m1: + pre (bblock_smem p) ge m0 -> + (forall x, term_eval ge (bblock_smem p x) m0 = Some (m1 x)) + -> res_eq (Some m1) (run ge p m0). +Proof. + intros; eapply bblocks_smem_rec_Some_correct2; eauto. +Qed. + +Lemma inst_valid i m0 old (od:smem): + (forall x, term_eval ge (od x) m0 = Some (old x)) -> + forall (m1 m2: mem) (d: smem), + pre d ge m0 -> + inst_run ge i m1 old = Some m2 -> + (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> + pre (inst_smem i d od) ge m0. +Proof. + induction i as [|[x e] i IHi]; simpl; auto. + intros Hold m1 m2 d VALID0 H Hm1. + destruct (exp_eval ge e m1 old) eqn: Heq; simpl; try congruence. + eapply IHi; eauto. + + unfold smem_set in * |- *; simpl. + rewrite Hm1; intuition congruence. + + intros x0. unfold assign, smem_set; simpl; destruct (R.eq_dec x x0); auto. + subst; erewrite term_eval_exp; eauto. +Qed. + + +Lemma block_smem_rec_valid p m0: forall (m1 m2: mem) (d:smem), + pre d ge m0 -> + run ge p m1 = Some m2 -> + (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> + pre (bblock_smem_rec p d) ge m0. +Proof. + Local Hint Resolve inst_valid: core. + induction p as [ | i p]; simpl; intros m1 d H; auto. + intros H0 H1. + destruct (inst_run ge i m1 m1) eqn: Heqov; eauto. + congruence. +Qed. + +Lemma bblock_smem_valid p m0 m1: + run ge p m0 = Some m1 -> + pre (bblock_smem p) ge m0. +Proof. + intros; eapply block_smem_rec_valid; eauto. + unfold smem_empty; simpl. auto. +Qed. + +Definition smem_valid ge d m := pre d ge m /\ forall x, term_eval ge (d x) m <> None. + +Definition smem_simu (d1 d2: smem): Prop := + (forall m, smem_valid ge d1 m -> smem_valid ge d2 m) + /\ (forall m0 x, smem_valid ge d1 m0 -> + term_eval ge (d1 x) m0 = term_eval ge (d2 x) m0). + + +Theorem bblock_smem_simu p1 p2: + smem_simu (bblock_smem p1) (bblock_smem p2) -> + bblock_simu ge p1 p2. +Proof. + Local Hint Resolve bblock_smem_valid bblock_smem_Some_correct1: core. + intros (INCL & EQUIV) m DONTFAIL; unfold smem_valid in * |-. + destruct (run ge p1 m) as [m1|] eqn: RUN1; simpl; try congruence. + assert (X: forall x, term_eval ge (bblock_smem p1 x) m = Some (m1 x)); eauto. + eapply bblock_smem_Some_correct2; eauto. + + destruct (INCL m); intuition eauto. + congruence. + + intro x; erewrite <- EQUIV; intuition eauto. + congruence. +Qed. + +Lemma smem_valid_set_decompose_1 d t x m: + smem_valid ge (smem_set d x t) m -> smem_valid ge d m. +Proof. + unfold smem_valid; intros ((PRE1 & PRE2) & VALID); split. + + intuition. + + intros x0 H. case (R.eq_dec x x0). + * intuition congruence. + * intros DIFF; eapply VALID. erewrite set_spec_diff; eauto. +Qed. + +Lemma smem_valid_set_decompose_2 d t x m: + smem_valid ge (smem_set d x t) m -> term_eval ge t m <> None. +Proof. + unfold smem_valid; intros ((PRE1 & PRE2) & VALID) H. + generalize (VALID x); rewrite set_spec_eq. + tauto. +Qed. + +Lemma smem_valid_set_proof d x t m: + smem_valid ge d m -> term_eval ge t m <> None -> smem_valid ge (smem_set d x t) m. +Proof. + unfold smem_valid; intros (PRE & VALID) PREt. split. + + split; auto. + + intros x0; unfold smem_set; simpl; case (R.eq_dec x x0); intros; subst; auto. +Qed. + + +End SIMU_THEORY. + +(** REMARKS: more abstract formulation of the proof... + but relying on functional_extensionality. +*) +Definition smem_correct ge (d: smem) (m: mem) (om: option mem): Prop:= + forall m', om=Some m' <-> (d.(pre) ge m /\ forall x, term_eval ge (d x) m = Some (m' x)). + +Lemma bblock_smem_correct ge p m: smem_correct ge (bblock_smem p) m (run ge p m). +Proof. + unfold smem_correct; simpl; intros m'; split. + + intros; split. + * eapply bblock_smem_valid; eauto. + * eapply bblock_smem_Some_correct1; eauto. + + intros (H1 & H2). + destruct (bblock_smem_Some_correct2 ge p m m') as (m2 & X & Y); eauto. + rewrite X. f_equal. + apply FunctionalExtensionality.functional_extensionality; auto. +Qed. + +End SimuTheory. diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v index 89d41017..58455ada 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/lib/Asmblockgenproof0.v @@ -1,3 +1,9 @@ +(** * "block" version of Asmgenproof0 + + This module is largely adapted from Asmgenproof0.v of the other backends + It needs to stand apart because of the block structure, and the distinction control/basic that there isn't in the other backends + It has similar definitions than Asmgenproof0, but adapted to this new structure *) + Require Import Coqlib. Require Intv. Require Import AST. @@ -16,34 +22,22 @@ Require Import Asmblockgen. Require Import Conventions1. Require Import Axioms. Require Import Machblockgenproof. (* FIXME: only use to import [is_tail_app] and [is_tail_app_inv] *) +Require Import Asmblockprops. Module MB:=Machblock. -Module AB:=Asmvliw. - -Hint Extern 2 (_ <> _) => congruence: asmgen. - -Definition bblock_simu (ge: Genv.t fundef unit) (f: function) (bb bb': bblock) := - forall rs m, - exec_bblock ge f bb rs m <> Stuck -> - exec_bblock ge f bb rs m = exec_bblock ge f bb' rs m. +Module AB:=Asmblock. Lemma ireg_of_eq: forall r r', ireg_of r = OK r' -> preg_of r = IR r'. Proof. unfold ireg_of; intros. destruct (preg_of r); inv H; auto. -(* destruct b. all: try discriminate. - inv H1. auto. - *)Qed. +Qed. -(* FIXME - Replaced FR by IR for MPPA *) Lemma freg_of_eq: forall r r', freg_of r = OK r' -> preg_of r = IR r'. Proof. unfold freg_of; intros. destruct (preg_of r); inv H; auto. -(* destruct b. all: try discriminate. - inv H1. auto. - *)Qed. - +Qed. Lemma preg_of_injective: forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2. @@ -51,53 +45,6 @@ Proof. destruct r1; destruct r2; simpl; intros; reflexivity || discriminate. Qed. -Lemma preg_of_data: - forall r, data_preg (preg_of r) = true. -Proof. - intros. destruct r; reflexivity. -Qed. -Hint Resolve preg_of_data: asmgen. - -Lemma data_diff: - forall r r', - data_preg r = true -> data_preg r' = false -> r <> r'. -Proof. - congruence. -Qed. -Hint Resolve data_diff: asmgen. - -Lemma preg_of_not_SP: - forall r, preg_of r <> SP. -Proof. - intros. unfold preg_of; destruct r; simpl; congruence. -Qed. - -Lemma preg_of_not_PC: - forall r, preg_of r <> PC. -Proof. - intros. apply data_diff; auto with asmgen. -Qed. - -Hint Resolve preg_of_not_SP preg_of_not_PC: asmgen. - -Lemma nextblock_pc: - forall b rs, (nextblock b rs)#PC = Val.offset_ptr rs#PC (Ptrofs.repr (size b)). -Proof. - intros. apply Pregmap.gss. -Qed. - -Lemma nextblock_inv: - forall b r rs, r <> PC -> (nextblock b rs)#r = rs#r. -Proof. - intros. unfold nextblock. apply Pregmap.gso. red; intro; subst. auto. -Qed. - -Lemma nextblock_inv1: - forall b r rs, data_preg r = true -> (nextblock b rs)#r = rs#r. -Proof. - intros. apply nextblock_inv. red; intro; subst; discriminate. -Qed. - Lemma undef_regs_other: forall r rl rs, (forall r', In r' rl -> r <> r') -> @@ -277,24 +224,6 @@ Proof. exploit preg_of_injective; eauto. congruence. Qed. -(* Lemma agree_undef_regs2: - forall ms sp rl rs rs', - agree (Mach.undef_regs rl ms) sp rs -> - (forall r', data_preg r' = true -> preg_notin r' rl -> rs'#r' = rs#r') -> - agree (Mach.undef_regs rl ms) sp rs'. -Proof. - intros. destruct H. split; auto. - rewrite <- agree_sp0. apply H0; auto. - rewrite preg_notin_charact. intros. apply not_eq_sym. apply preg_of_not_SP. - intros. destruct (In_dec mreg_eq r rl). - rewrite Mach.undef_regs_same; auto. - rewrite H0; auto. - apply preg_of_data. - rewrite preg_notin_charact. intros; red; intros. elim n. - exploit preg_of_injective; eauto. congruence. -Qed. - *) - Lemma agree_set_undef_mreg: forall ms sp rs r v rl rs', agree ms sp rs -> @@ -312,9 +241,9 @@ Qed. Lemma agree_undef_caller_save_regs: forall ms sp rs, agree ms sp rs -> - agree (Mach.undef_caller_save_regs ms) sp (Asmvliw.undef_caller_save_regs rs). + agree (Mach.undef_caller_save_regs ms) sp (undef_caller_save_regs rs). Proof. - intros. destruct H. unfold Mach.undef_caller_save_regs, Asmvliw.undef_caller_save_regs; split. + intros. destruct H. unfold Mach.undef_caller_save_regs, undef_caller_save_regs; split. - unfold proj_sumbool; rewrite dec_eq_true. auto. - auto. - intros. unfold proj_sumbool. rewrite dec_eq_false by (apply preg_of_not_SP). @@ -485,7 +414,7 @@ Proof. Qed. -Local Hint Resolve code_tail_0 code_tail_S. +Local Hint Resolve code_tail_0 code_tail_S: core. Lemma code_tail_next: forall fn ofs c0, @@ -529,7 +458,7 @@ Proof. omega. Qed. -Local Hint Resolve code_tail_next. +Local Hint Resolve code_tail_next: core. Lemma code_tail_next_int: forall fn ofs bi c, @@ -607,15 +536,13 @@ Hypothesis transf_function_len: forall f tf, transf_function f = OK tf -> size_blocks (fn_blocks tf) <= Ptrofs.max_unsigned. -(* NB: the hypothesis in comment on [b] is not needed in the proof ! *) Lemma return_address_exists: - forall b f (* sg ros *) c, (* b.(MB.exit) = Some (MBcall sg ros) -> *) is_tail (b :: c) f.(MB.fn_code) -> + forall b f c, is_tail (b :: c) f.(MB.fn_code) -> exists ra, return_address_offset f c ra. Proof. intros. destruct (transf_function f) as [tf|] eqn:TF. + exploit transf_function_inv; eauto. intros (tc1 & ep1 & TR1 & TL1). exploit transl_blocks_tail; eauto. intros (tc2 & ep2 & TR2 & TL2). -(* unfold return_address_offset. *) monadInv TR2. assert (TL3: is_tail x0 (fn_blocks tf)). { apply is_tail_trans with tc1; auto. @@ -632,7 +559,7 @@ Qed. End RETADDR_EXISTS. (** [transl_code_at_pc pc fb f c ep tf tc] holds if the code pointer [pc] points - within the Asm code generated by translating Mach function [f], + within the Asmblock code generated by translating Machblock function [f], and [tc] is the tail of the generated code at the position corresponding to the code pointer [pc]. *) @@ -772,6 +699,19 @@ Proof. intros. destruct H. auto. Qed. +Lemma exec_body_pc: + forall ge l rs1 m1 rs2 m2, + exec_body ge l rs1 m1 = Next rs2 m2 -> + rs2 PC = rs1 PC. +Proof. + induction l. + - intros. inv H. auto. + - intros until m2. intro EXEB. + inv EXEB. destruct (exec_basic_instr _ _ _ _) eqn:EBI; try discriminate. + eapply IHl in H0. rewrite H0. + erewrite exec_basic_instr_pc; eauto. +Qed. + Section STRAIGHTLINE. Variable ge: genv. @@ -850,18 +790,6 @@ Proof. apply exec_straight_step with rs2 m2; auto. Qed. -(* Theorem exec_straight_bblock: - forall rs1 m1 rs2 m2 rs3 m3 b, - exec_straight (body b) rs1 m1 nil rs2 m2 -> - exec_control_rel (exit b) b rs2 m2 rs3 m3 -> - exec_bblock_rel b rs1 m1 rs3 m3. -Proof. - intros. - econstructor; eauto. unfold exec_bblock. erewrite exec_straight_body; eauto. - inv H0. auto. -Qed. *) - - Lemma exec_straight_two: forall i1 i2 c rs1 m1 rs2 m2 rs3 m3, exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> @@ -912,79 +840,6 @@ Qed. (** Linking exec_straight with exec_straight_blocks *) -Ltac Simplif := - ((rewrite nextblock_inv by eauto with asmgen) - || (rewrite nextblock_inv1 by eauto with asmgen) - || (rewrite Pregmap.gss) - || (rewrite nextblock_pc) - || (rewrite Pregmap.gso by eauto with asmgen) - ); auto with asmgen. - -Ltac Simpl := repeat Simplif. - -Lemma exec_basic_instr_pc: - forall b rs1 m1 rs2 m2, - exec_basic_instr ge b rs1 m1 = Next rs2 m2 -> - rs2 PC = rs1 PC. -Proof. - intros. destruct b; try destruct i; try destruct i. - all: try (inv H; Simpl). - 1-10: try (unfold parexec_load_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]). - 1-10: try (unfold parexec_load_reg in H1; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]). - 1-10: try (unfold parexec_load_regxs in H1; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]). - 1-10: try (unfold parexec_store_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]). - 1-10: try (unfold parexec_store_reg in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]); auto. - 1-10: try (unfold parexec_store_regxs in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]); auto. - - (* PLoadQRRO *) - unfold parexec_load_q_offset in H1. - destruct (gpreg_q_expand _) as [r0 r1] in H1. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - inv H1. Simpl. - - (* PLoadORRO *) - unfold parexec_load_o_offset in H1. - destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - inv H1. Simpl. - - (* PStoreQRRO *) - unfold parexec_store_q_offset in H1. - destruct (gpreg_q_expand _) as [r0 r1] in H1. - unfold eval_offset in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - inv H1. Simpl. reflexivity. - - (* PStoreORRO *) - unfold parexec_store_o_offset in H1. - destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. - unfold eval_offset in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - inv H1. Simpl. reflexivity. - - destruct (Mem.alloc _ _ _). destruct (Mem.store _ _ _ _ _). inv H1. Simpl. discriminate. - - destruct (Mem.loadv _ _ _); try discriminate. destruct (rs1 _); try discriminate. - destruct (Mem.free _ _ _ _). inv H1. Simpl. discriminate. - - destruct rs; try discriminate. inv H1. Simpl. - - destruct rd; try discriminate. inv H1; Simpl. - - reflexivity. -Qed. - -(* Lemma exec_straight_pc': - forall c rs1 m1 rs2 m2, - exec_straight c rs1 m1 nil rs2 m2 -> - rs2 PC = rs1 PC. -Proof. - induction c; intros; try (inv H; fail). - inv H. - - erewrite exec_basic_instr_pc; eauto. - - rewrite (IHc rs3 m3 rs2 m2); auto. - erewrite exec_basic_instr_pc; eauto. -Qed. *) - Lemma exec_straight_pc: forall c c' rs1 m1 rs2 m2, exec_straight c rs1 m1 c' rs2 m2 -> @@ -997,25 +852,6 @@ Proof. erewrite exec_basic_instr_pc; eauto. Qed. -(* Lemma exec_straight_through: - forall c i b lb rs1 m1 rs2 m2 rs2' m2', - bblock_basic_ctl c i = b -> - exec_straight c rs1 m1 nil rs2 m2 -> - nextblock b rs2 = rs2' -> m2 = m2' -> - exec_control ge fn i rs2' m2' = Next rs2' m2' -> (* if the control does not jump *) - exec_straight_blocks (b::lb) rs1 m1 lb rs2' m2'. -Proof. - intros. subst. destruct i. - - constructor 1. - + unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto. - + rewrite <- (exec_straight_pc c nil rs1 m1 rs2 m2'); auto. - - destruct c as [|i c]; try (inv H0; fail). - constructor 1. - + unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto. - + rewrite <- (exec_straight_pc (i ::i c) nil rs1 m1 rs2 m2'); auto. -Qed. - *) - Lemma regset_same_assign (rs: regset) r: rs # r <- (rs r) = rs. Proof. @@ -1034,8 +870,6 @@ Proof. simpl; auto. unfold nextblock, incrPC; simpl. Simpl. erewrite exec_straight_pc; eauto. Qed. - - (** The following lemmas show that straight-line executions (predicate [exec_straight_blocks]) correspond to correct Asm executions. *) @@ -1086,7 +920,6 @@ Qed. End STRAIGHTLINE. - (** * Properties of the Machblock call stack *) Section MATCH_STACK. diff --git a/mppa_k1c/lib/ForwardSimulationBlock.v b/mppa_k1c/lib/ForwardSimulationBlock.v index 39dd2234..224eda0a 100644 --- a/mppa_k1c/lib/ForwardSimulationBlock.v +++ b/mppa_k1c/lib/ForwardSimulationBlock.v @@ -21,7 +21,7 @@ Section starN_lemma. Variable L: semantics. -Local Hint Resolve starN_refl starN_step Eapp_assoc. +Local Hint Resolve starN_refl starN_step Eapp_assoc: core. Lemma starN_split n s t s': starN (step L) (globalenv L) n s t s' -> @@ -93,7 +93,7 @@ Hypothesis simu_end_block: (** Introduction d'une sémantique par bloc sur L1 appelée "memoL1" *) -Local Hint Resolve starN_refl starN_step. +Local Hint Resolve starN_refl starN_step: core. Definition follows_in_block (head current: state L1): Prop := dist_end_block head >= dist_end_block current @@ -164,7 +164,7 @@ Inductive is_well_memorized (s s': memostate): Prop := memorized s' = None -> is_well_memorized s s'. -Local Hint Resolve StartBloc MidBloc ExitBloc. +Local Hint Resolve StartBloc MidBloc ExitBloc: core. Definition memoL1 := {| state := memostate; diff --git a/mppa_k1c/lib/Machblock.v b/mppa_k1c/lib/Machblock.v index 30393fd5..5a7f1782 100644 --- a/mppa_k1c/lib/Machblock.v +++ b/mppa_k1c/lib/Machblock.v @@ -14,19 +14,19 @@ Require Stacklayout. Require Import Mach. Require Import Linking. -(** instructions "basiques" (ie non control-flow) *) +(** basic instructions (ie no control-flow) *) Inductive basic_inst: Type := | MBgetstack: ptrofs -> typ -> mreg -> basic_inst | MBsetstack: mreg -> ptrofs -> typ -> basic_inst | MBgetparam: ptrofs -> typ -> mreg -> basic_inst | MBop: operation -> list mreg -> mreg -> basic_inst - | MBload: memory_chunk -> addressing -> list mreg -> mreg -> basic_inst + | MBload: trapping_mode -> memory_chunk -> addressing -> list mreg -> mreg -> basic_inst | MBstore: memory_chunk -> addressing -> list mreg -> mreg -> basic_inst . Definition bblock_body := list basic_inst. -(** instructions de control flow *) +(** control flow instructions *) Inductive control_flow_inst: Type := | MBcall: signature -> mreg + ident -> control_flow_inst | MBtailcall: signature -> mreg + ident -> control_flow_inst @@ -207,11 +207,22 @@ Inductive basic_step (s: list stackframe) (fb: block) (sp: val) (rs: regset) (m: rs' = ((undef_regs (destroyed_by_op op) rs)#res <- v) -> basic_step s fb sp rs m (MBop op args res) rs' m | exec_MBload: - forall addr args a v rs' chunk dst, + forall addr args a v rs' trap chunk dst, eval_addressing ge sp addr rs##args = Some a -> Mem.loadv chunk m a = Some v -> rs' = ((undef_regs (destroyed_by_load chunk addr) rs)#dst <- v) -> - basic_step s fb sp rs m (MBload chunk addr args dst) rs' m + basic_step s fb sp rs m (MBload trap chunk addr args dst) rs' m + | exec_MBload_notrap1: + forall addr args rs' chunk dst, + eval_addressing ge sp addr rs##args = None -> + rs' = ((undef_regs (destroyed_by_load chunk addr) rs)#dst <- (default_notrap_load_value chunk)) -> + basic_step s fb sp rs m (MBload NOTRAP chunk addr args dst) rs' m + | exec_MBload_notrap2: + forall addr args a rs' chunk dst, + eval_addressing ge sp addr rs##args = Some a -> + Mem.loadv chunk m a = None -> + rs' = ((undef_regs (destroyed_by_load chunk addr) rs)#dst <- (default_notrap_load_value chunk)) -> + basic_step s fb sp rs m (MBload NOTRAP chunk addr args dst) rs' m | exec_MBstore: forall chunk addr args src m' a rs', eval_addressing ge sp addr rs##args = Some a -> diff --git a/mppa_k1c/lib/Machblockgen.v b/mppa_k1c/lib/Machblockgen.v index 4dfc309e..2ba42814 100644 --- a/mppa_k1c/lib/Machblockgen.v +++ b/mppa_k1c/lib/Machblockgen.v @@ -33,7 +33,7 @@ Definition trans_inst (i:Mach.instruction) : Machblock_inst := | Msetstack src ofs ty => MB_basic (MBsetstack src ofs ty) | Mgetparam ofs ty dst => MB_basic (MBgetparam ofs ty dst) | Mop op args res => MB_basic (MBop op args res) - | Mload chunk addr args dst => MB_basic (MBload chunk addr args dst) + | Mload trap chunk addr args dst=> MB_basic (MBload trap chunk addr args dst) | Mstore chunk addr args src => MB_basic (MBstore chunk addr args src) | Mlabel l => MB_label l end. @@ -57,12 +57,9 @@ Definition add_to_new_bblock (i:Machblock_inst) : bblock := | MB_cfi i => cfi_bblock i end. -(* ajout d'une instruction en début d'une liste de blocks *) -(* Soit /1\ ajout en tête de block, soit /2\ ajout dans un nouveau block*) -(* bl est vide -> /2\ *) -(* cfi -> /2\ (ajout dans exit)*) -(* basic -> /1\ si header vide, /2\ si a un header *) -(* label -> /1\ (dans header)*) +(** Adding an instruction to the beginning of a bblock list + * Either adding the instruction to the head of the list, + * or create a new bblock with the instruction *) Definition add_to_code (i:Machblock_inst) (bl:code) : code := match bl with | bh::bl0 => match i with @@ -86,8 +83,6 @@ Fixpoint trans_code_rev (c: Mach.code) (bl:code) : code := Function trans_code (c: Mach.code) : code := trans_code_rev (List.rev_append c nil) nil. - -(* à finir pour passer des Mach.function au function, etc. *) Definition transf_function (f: Mach.function) : function := {| fn_sig:=Mach.fn_sig f; fn_code:=trans_code (Mach.fn_code f); @@ -103,14 +98,14 @@ Definition transf_program (src: Mach.program) : program := transform_program transf_fundef src. -(** Abstraction de trans_code *) +(** Abstracting trans_code *) Inductive is_end_block: Machblock_inst -> code -> Prop := | End_empty mbi: is_end_block mbi nil | End_basic bi bh bl: header bh <> nil -> is_end_block (MB_basic bi) (bh::bl) | End_cfi cfi bl: bl <> nil -> is_end_block (MB_cfi cfi) bl. -Local Hint Resolve End_empty End_basic End_cfi. +Local Hint Resolve End_empty End_basic End_cfi: core. Inductive is_trans_code: Mach.code -> code -> Prop := | Tr_nil: is_trans_code nil nil @@ -128,7 +123,7 @@ Inductive is_trans_code: Mach.code -> code -> Prop := header bh = nil -> is_trans_code (i::c) (add_basic bi bh::bl). -Local Hint Resolve Tr_nil Tr_end_block. +Local Hint Resolve Tr_nil Tr_end_block: core. Lemma add_to_code_is_trans_code i c bl: is_trans_code c bl -> @@ -150,7 +145,7 @@ Proof. rewrite <- Heqti. eapply End_cfi. congruence. Qed. -Local Hint Resolve add_to_code_is_trans_code. +Local Hint Resolve add_to_code_is_trans_code: core. Lemma trans_code_is_trans_code_rev c1: forall c2 mbi, is_trans_code c2 mbi -> @@ -190,7 +185,7 @@ Proof. exists mbi1. split; congruence. Qed. -Local Hint Resolve trans_code_is_trans_code. +Local Hint Resolve trans_code_is_trans_code: core. Theorem is_trans_code_inv c bl: is_trans_code c bl <-> bl=(trans_code c). Proof. diff --git a/mppa_k1c/lib/Machblockgenproof.v b/mppa_k1c/lib/Machblockgenproof.v index 9186e54a..0de2df52 100644 --- a/mppa_k1c/lib/Machblockgenproof.v +++ b/mppa_k1c/lib/Machblockgenproof.v @@ -72,7 +72,7 @@ Proof. apply match_states_trans_state. Qed. -Local Hint Resolve match_states_trans_state. +Local Hint Resolve match_states_trans_state: core. Lemma symbols_preserved: forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. @@ -284,7 +284,7 @@ Proof. Qed. Local Hint Resolve symbols_preserved senv_preserved init_mem_preserved prog_main_preserved functions_translated - parent_sp_preserved. + parent_sp_preserved: core. Definition dist_end_block_code (c: Mach.code) := @@ -299,8 +299,8 @@ Definition dist_end_block (s: Mach.state): nat := | _ => 0 end. -Local Hint Resolve exec_nil_body exec_cons_body. -Local Hint Resolve exec_MBgetstack exec_MBsetstack exec_MBgetparam exec_MBop exec_MBload exec_MBstore. +Local Hint Resolve exec_nil_body exec_cons_body: core. +Local Hint Resolve exec_MBgetstack exec_MBsetstack exec_MBgetparam exec_MBop exec_MBload exec_MBstore: core. Lemma size_add_label l bh: size (add_label l bh) = size bh + 1. Proof. @@ -336,7 +336,7 @@ Proof. omega. Qed. -Local Hint Resolve dist_end_block_code_simu_mid_block. +Local Hint Resolve dist_end_block_code_simu_mid_block: core. Lemma size_nonzero c b bl: @@ -392,8 +392,8 @@ destruct i; congruence. Qed. -Local Hint Resolve Mlabel_is_not_cfi. -Local Hint Resolve MBbasic_is_not_cfi. +Local Hint Resolve Mlabel_is_not_cfi: core. +Local Hint Resolve MBbasic_is_not_cfi: core. Lemma add_to_new_block_is_label i: header (add_to_new_bblock (trans_inst i)) <> nil -> exists l, i = Mlabel l. @@ -408,7 +408,7 @@ Proof. + unfold cfi_bblock in H; simpl in H; congruence. Qed. -Local Hint Resolve Mlabel_is_not_basic. +Local Hint Resolve Mlabel_is_not_basic: core. Lemma trans_code_decompose c: forall b bl, is_trans_code c (b::bl) -> @@ -483,6 +483,10 @@ Proof. unfold Genv.symbol_address; rewrite symbols_preserved; auto. - eapply exec_MBload; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto; unfold Genv.symbol_address; rewrite symbols_preserved; auto. + - eapply exec_MBload_notrap1; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto; + unfold Genv.symbol_address; rewrite symbols_preserved; auto. + - eapply exec_MBload_notrap2; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto; + unfold Genv.symbol_address; rewrite symbols_preserved; auto. - eapply exec_MBstore; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto; unfold Genv.symbol_address; rewrite symbols_preserved; auto. Qed. @@ -506,8 +510,8 @@ Proof. rewrite Hs2, Hb2; eauto. Qed. -Local Hint Resolve exec_MBcall exec_MBtailcall exec_MBbuiltin exec_MBgoto exec_MBcond_true exec_MBcond_false exec_MBjumptable exec_MBreturn exec_Some_exit exec_None_exit. -Local Hint Resolve eval_builtin_args_preserved external_call_symbols_preserved find_funct_ptr_same. +Local Hint Resolve exec_MBcall exec_MBtailcall exec_MBbuiltin exec_MBgoto exec_MBcond_true exec_MBcond_false exec_MBjumptable exec_MBreturn exec_Some_exit exec_None_exit: core. +Local Hint Resolve eval_builtin_args_preserved external_call_symbols_preserved find_funct_ptr_same: core. Lemma match_states_concat_trans_code st f sp c rs m h: @@ -715,11 +719,11 @@ Proof. intro H; destruct c as [|i' c]. { inversion H. } remember (trans_inst i) as ti. destruct ti as [lbl|bi|cfi]. - - (*i=lbl *) cutrewrite (i = Mlabel lbl). 2:{ destruct i; simpl in * |- *; try congruence. } + - (*i=lbl *) cutrewrite (i = Mlabel lbl). 2: ( destruct i; simpl in * |- *; try congruence ). exists nil; simpl; eexists. eapply Tr_add_label; eauto. - (*i=basic*) destruct i'. - 10: {exists (add_to_new_bblock (MB_basic bi)::nil). exists b. + 10: { exists (add_to_new_bblock (MB_basic bi)::nil). exists b. cutrewrite ((add_to_new_bblock (MB_basic bi) :: nil) ++ (b::l)=(add_to_new_bblock (MB_basic bi) :: (b::l)));eauto. rewrite Heqti. eapply Tr_end_block; eauto. |